src/tool/Creation_Maillage/cmh400.F

   1       subroutine cmh400 ( lehexa,
   2      >                    indnoe, indare, indtet, indpyr, indhex,
   3      >                    indptp,
   4      >                    listso, listar, listfa, listcf,
   5      >                    coonoe, hetnoe, arenoe,
   6      >                    famnoe,
   7      >                    hetare, somare,
   8      >                    filare, merare, famare,
   9      >                    aretri,
  10      >                    arequa, filqua,
  11      >                    hettet, aretet,
  12      >                    filtet, pertet, famtet,
  13      >                    hetpyr, arepyr,
  14      >                    filpyr, perpyr, fampyr,
  15      >                    hethex, arehex,
  16      >                    filhex, perhex, famhex,
  17      >                    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 - decoupage de conformite des Hexaedres
  40 c    -           -                                      -
  41 c ______________________________________________________________________
  42 c .        .     .        .                                            .
  43 c .  nom   . e/s . taille .           description                      .
  44 c .____________________________________________________________________.
  45 c . lehexa . e   .   1    . hexaedre a decouper                        .
  46 c . indnoe . es  .   1    . indice du dernier noeud cree               .
  47 c . indare . es  .   1    . indice de la derniere arete creee          .
  48 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  49 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  50 c . indhex . es  .   1    . indice du dernier hexaedre cree            .
  51 c . indptp . es  .   1    . indice du dernier pere enregistre          .
  52 c . listso . e   .   8    . numeros globaux des sommets                .
  53 c . listar . e   .  12    . numeros globaux des aretes                 .
  54 c . listfa . e   .   6    . numeros globaux des faces                  .
  55 c . listcf . e   .   6    . codes des faces                            .
  56 c . coonoe . es  .nouvno*3. coordonnees des noeuds                     .
  57 c . hetnoe . es  . nouvno . historique de l'etat des noeuds            .
  58 c . arenoe . es  . nouvno . arete liee a un nouveau noeud              .
  59 c . famnoe . es  . nouvno . famille des noeuds                         .
  60 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  61 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  62 c . filare . es  . nouvar . premiere fille des aretes                  .
  63 c . merare . es  . nouvar . mere des aretes                            .
  64 c . famare . es  . nouvar . famille des aretes                         .
  65 c . aretri . e   .nouvtr*3. numeros des 3 aretes des triangles         .
  66 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  67 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  68 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  69 c . aretet . es  .nouvta*6. numeros des 6 aretes des tetraedres        .
  70 c . filtet . es  . nouvte . premier fils des tetraedres                .
  71 c . pertet . es  . nouvte . pere des tetraedres                        .
  72 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  73 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  74 c . famtet . es  . nouvte . famille des tetraedres                     .
  75 c . hetpyr . es  . nouvpy . historique de l'etat des pyramides         .
  76 c . arepyr . es  .nouvya*8. numeros des 8 aretes des pyramides         .
  77 c . filpyr . es  . nouvpy . premier fils des pyramides                 .
  78 c . perpyr . es  . nouvpy . pere des pyramides                         .
  79 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  80 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  81 c . fampyr . es  . nouvpy . famille des pyramides                      .
  82 c . hethex . es  . nouvhe . historique de l'etat des hexaedres         .
  83 c . arehex . es  .nouvha12. numeros des 12 aretes des hexaedres        .
  84 c . filhex . es  . nouvhe . premier fils des hexaedres                 .
  85 c . perhex . es  . nouvhe . pere des hexaedres                         .
  86 c . famhex . es  . nouvhe . famille des hexaedres                      .
  87 c . cfahex . e   . nctfhe. codes des familles des hexaedres            .
  88 c .        .     . nbfhex .   1 : famille MED                          .
  89 c .        .     .        .   2 : type d'hexaedres                     .
  90 c .        .     .        .   3 : famille des tetraedres de conformite .
  91 c .        .     .        .   4 : famille des pyramides de conformite  .
  92 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  93 c . langue . e   .    1   . langue des messages                        .
  94 c .        .     .        . 1 : francais, 2 : anglais                  .
  95 c . codret . es  .    1   . code de retour des modules                 .
  96 c ______________________________________________________________________
  97 c
  98 c====
  99 c 0. declarations et dimensionnement
 100 c====
 101 c
 102 c 0.1. ==> generalites
 103 c
 104       implicit none
 105       save
 106 c
 107       integer nbarin
 108       character*6 nompro
 109       parameter ( nompro ='CMH400' )
 110       parameter ( nbarin = 13 )
 111 c
 112       integer nbsomm
 113       parameter ( nbsomm = 8 )
 114 c
 115 #include "nblang.h"
 116 #include "cofpfh.h"
 117 #include "coftfh.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 indnoe, indare, indtet, indpyr, indhex
 132       integer indptp
 133       integer listso(8), listar(12), listfa(6), listcf(6)
 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 aretri(nouvtr,3)
 139       integer arequa(nouvqu,4)
 140       integer filqua(nouvqu)
 141       integer hettet(nouvte), aretet(nouvta,6)
 142       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 143       integer hetpyr(nouvpy), arepyr(nouvya,8)
 144       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 145       integer arehex(nouvha,12)
 146       integer hethex(nouvhe)
 147       integer filhex(nouvhe), perhex(nouvhe)
 148       integer cfahex(nctfhe,nbfhex), famhex(nouvhe)
 149 c
 150       double precision coonoe(nouvno,sdim)
 151 c
 152       integer ulsort, langue, codret
 153 c
 154 c 0.4. ==> variables locales
 155 c
 156       integer iaux
 157 c
 158       integer lesnoe(nbarin), areint(nbarin)
 159       integer lisomm(10), liarin(10)
 160       integer fdnume, fdcode
 161       integer are1, are2, are3, are4
 162       integer are5, are6, are7, are8
 163
 164 #include "defiqu.h"
 165 c
 166       integer laface, letria
 167       integer niveau, nf1
 168       integer quabas(4)
 169       integer an1nf1, an2nf1, an3nf1, an4nf1
 170       integer as5n1, as6n1, as1n1, as2n1
 171       integer as6n2, as7n2, as1n2, as4n2
 172       integer as5n3, as8n3, as2n3, as3n3
 173       integer as7n4, as8n4, as4n4, as3n4
 174       integer nufami
 175 c
 176       integer nbmess
 177       parameter ( nbmess = 10 )
 178       character*80 texte(nblang,nbmess)
 179 c
 180 c 0.5. ==> initialisations
 181 c ______________________________________________________________________
 182 c
 183 c====
 184 c 1. messages
 185 c====
 186 c
 187 #include "impr01.h"
 188 #include "impr03.h"
 189 c
 190 #ifdef _DEBUG_HOMARD_
 191       write (ulsort,texte(langue,1)) 'Entree', nompro
 192       call dmflsh (iaux)
 193 #endif
 194 c
 195 #ifdef _DEBUG_HOMARD_
 196       write (ulsort,90002) 'indnoe', indnoe
 197       write (ulsort,90002) 'indtet', indtet
 198       write (ulsort,90002) 'indpyr', indpyr
 199       write (ulsort,90002) 'indhex', indhex
 200 #endif
 201 #ifdef _DEBUG_HOMARD_
 202       write (ulsort,90002) 'listar  1-8', (listar(iaux),iaux=1,8)
 203       write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12)
 204       write (ulsort,90002) 'listso', listso
 205       write (ulsort,90002) 'listfa', listfa
 206       write (ulsort,90002) 'listcf', listcf
 207 #endif
 208 c
 209       codret = 0
 210 c
 211 c====
 212 c 2. Recuperation
 213 c    . des sommets de l'hexaedre
 214 c    . des noeuds milieux des 4 aretes coupees
 215 c    . du noeud milieu de la face coupee en 4 quadrangles
 216 c====
 217 c
 218       do 21 , iaux = 1 , 8
 219         lesnoe(iaux) = listso(iaux)
 220    21 continue
 221 c
 222       lesnoe(9) = somare(2,filare(listar(1)))
 223       lesnoe(10) = somare(2,filare(listar(2)))
 224       lesnoe(11) = somare(2,filare(listar(3)))
 225       lesnoe(12) = somare(2,filare(listar(4)))
 226 c
 227       iaux = filqua(listfa(1))
 228       lesnoe(13) = somare(2,arequa(iaux,2))
 229 #ifdef _DEBUG_HOMARD_
 230       do 2000 , iaux = 1 , nbarin
 231         write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux)
 232  2000 continue
 233 #endif
 234 c
 235 c La face coupee en 4 et son code dans l'hexaedre
 236 c
 237       fdnume = listfa(1)
 238       fdcode = listcf(1)
 239 #ifdef _DEBUG_HOMARD_
 240       write(ulsort,90002) 'fdnume, fdcode', fdnume, fdcode
 241 #endif
 242 c
 243 c====
 244 c 3. Recuperation du noeud central de la face coupee en 4
 245 c====
 246 c
 247       iaux = filqua(fdnume)
 248       nf1 = somare(2,arequa(iaux,2))
 249 #ifdef _DEBUG_HOMARD_
 250       write(ulsort,90002) 'nf1', nf1
 251 #endif
 252 c
 253 c====
 254 c 4. Recuperation des aretes tracees sur la face coupee en 4
 255 c    quabas stocke les quadrangles fils de la face coupee en 4
 256 c    quabas(p) est la base de la pyramide fille numero p
 257 c    filqua(fdnume) + defiqJ(fdcode) : J-eme fils du quadrangle
 258 c    Attention : la regle de numerotation locale des quadrangles quabas
 259 c                est celle des pyramides ; on part du sommet de plus
 260 c                petit numero local et on tourne en entrant dans
 261 c                l'hexaedre. Pour les fils du quadrangle, on part de la
 262 c                plus petite arete locale et on tourne dans le meme sens
 263 c                D'ou l'eventuel decalage selon les faces
 264 c====
 265 c
 266 #ifdef _DEBUG_HOMARD_
 267       write(ulsort,90002) 'defiq1', defiq1(fdcode)
 268       write(ulsort,90002) 'defiq2', defiq2(fdcode)
 269       write(ulsort,90002) 'defiq3', defiq3(fdcode)
 270       write(ulsort,90002) 'defiq4', defiq4(fdcode)
 271 #endif
 272       quabas(1) = filqua(fdnume) + defiq2(fdcode)
 273       quabas(2) = filqua(fdnume) + defiq3(fdcode)
 274       quabas(3) = filqua(fdnume) + defiq4(fdcode)
 275       quabas(4) = filqua(fdnume) + defiq1(fdcode)
 276 #ifdef _DEBUG_HOMARD_
 277       write(ulsort,90002) 'Fils aine', filqua(fdnume)
 278       write(ulsort,90006) 'quabas(1) :', quabas(1)
 279       write(ulsort,90006) 'quabas(2) :', quabas(2)
 280       write(ulsort,90006) 'quabas(3) :', quabas(3)
 281       write(ulsort,90006) 'quabas(4) :', quabas(4)
 282 #endif
 283 c
 284       if ( fdcode.lt.5 ) then
 285        an2nf1 = arequa(quabas(1),2)
 286        an4nf1 = arequa(quabas(2),2)
 287        an3nf1 = arequa(quabas(3),2)
 288        an1nf1 = arequa(quabas(4),2)
 289       else
 290        an2nf1 = arequa(quabas(2),2)
 291        an4nf1 = arequa(quabas(3),2)
 292        an3nf1 = arequa(quabas(4),2)
 293        an1nf1 = arequa(quabas(1),2)
 294       endif
 295 #ifdef _DEBUG_HOMARD_
 296       write(ulsort,90015) 'an2nf1', an2nf1, ' entre les noeuds',
 297      >                    somare(1,an2nf1), somare(2,an2nf1)
 298       write(ulsort,90015) 'an4nf1', an4nf1, ' entre les noeuds',
 299      >                    somare(1,an4nf1), somare(2,an4nf1)
 300       write(ulsort,90015) 'an3nf1', an3nf1, ' entre les noeuds',
 301      >                    somare(1,an3nf1), somare(2,an3nf1)
 302       write(ulsort,90015) 'an1nf1', an1nf1, ' entre les noeuds',
 303      >                    somare(1,an1nf1), somare(2,an1nf1)
 304 #endif
 305 c
 306 c====
 307 c 5. Recuperation des aretes tracees sur les faces coupees en 3
 308 c====
 309 c
 310       laface = listfa(2)
 311       letria = -filqua(laface)
 312       if ( listcf(2).lt.5 ) then
 313         as5n1 = aretri(letria,1)
 314         as6n1 = aretri(letria,3)
 315         as1n1 = aretri(letria+2,1)
 316         as2n1 = aretri(letria+1,1)
 317       else
 318         as5n1 = aretri(letria,3)
 319         as6n1 = aretri(letria,1)
 320         as1n1 = aretri(letria+1,1)
 321         as2n1 = aretri(letria+2,1)
 322       endif
 323 c
 324       laface = listfa(3)
 325       letria = -filqua(laface)
 326       if ( listcf(3).lt.5 ) then
 327         as6n2 = aretri(letria,1)
 328         as7n2 = aretri(letria,3)
 329         as1n2 = aretri(letria+1,1)
 330         as4n2 = aretri(letria+2,1)
 331       else
 332         as6n2 = aretri(letria,3)
 333         as7n2 = aretri(letria,1)
 334         as1n2 = aretri(letria+2,1)
 335         as4n2 = aretri(letria+1,1)
 336       endif
 337 c
 338       laface = listfa(4)
 339       letria = -filqua(laface)
 340       if ( listcf(4).lt.5 ) then
 341         as5n3 = aretri(letria,3)
 342         as8n3 = aretri(letria,1)
 343         as2n3 = aretri(letria+2,1)
 344         as3n3 = aretri(letria+1,1)
 345       else
 346         as5n3 = aretri(letria,1)
 347         as8n3 = aretri(letria,3)
 348         as2n3 = aretri(letria+1,1)
 349         as3n3 = aretri(letria+2,1)
 350       endif
 351 c
 352       laface = listfa(5)
 353       letria = -filqua(laface)
 354       if ( listcf(5).lt.5 ) then
 355         as7n4 = aretri(letria,1)
 356         as8n4 = aretri(letria,3)
 357         as4n4 = aretri(letria+1,1)
 358         as3n4 = aretri(letria+2,1)
 359       else
 360         as7n4 = aretri(letria,3)
 361         as8n4 = aretri(letria,1)
 362         as4n4 = aretri(letria+2,1)
 363         as3n4 = aretri(letria+1,1)
 364       endif
 365 c
 366 #ifdef _DEBUG_HOMARD_
 367       write(ulsort,90002) 'as5n1, as6n1, as1n1, as2n1',
 368      >                     as5n1, as6n1, as1n1, as2n1
 369       write(ulsort,90002) 'as6n2, as7n2, as1n2, as4n2',
 370      >                     as6n2, as7n2, as1n2, as4n2
 371       write(ulsort,90002) 'as5n3, as8n3, as2n3, as3n3',
 372      >                     as5n3, as8n3, as2n3, as3n3
 373       write(ulsort,90002) 'as7n4, as8n4, as4n4, as3n4',
 374      >                     as7n4, as8n4, as4n4, as3n4
 375 #endif
 376 c
 377 c====
 378 c 6. Creation des quatre aretes internes
 379 c    areint(1) : AS5NF1
 380 c    areint(2) : AS6NF1
 381 c    areint(3) : AS7NF1
 382 c    areint(4) : AS8NF1
 383 c====
 384 c
 385       do 61 , iaux = 1 , 4
 386 c
 387         indare = indare + 1
 388         areint(iaux) = indare
 389 c
 390         somare(1,areint(iaux)) = min ( nf1 , listso(4+iaux) )
 391         somare(2,areint(iaux)) = max ( nf1 , listso(4+iaux) )
 392 c
 393         famare(areint(iaux)) = 1
 394         hetare(areint(iaux)) = 50
 395         merare(areint(iaux)) = 0
 396         filare(areint(iaux)) = 0
 397 #ifdef _DEBUG_HOMARD_
 398       write(ulsort,90006) 'areint(iaux) = ', areint(iaux),
 399      >                    ' de ',somare(1,areint(iaux)),
 400      >                    ' a ',somare(2,areint(iaux))
 401 #endif
 402 c
 403    61 continue
 404 c
 405 c====
 406 c 5. Creation des 5 pyramides
 407 c====
 408 c
 409       iaux = -indptp
 410       nufami = cfahex(cofpfh,famhex(lehexa))
 411 c
 412 c 5.1. ==> Pyramide s'appuyant sur la face non decoupee
 413 c
 414       indpyr = indpyr + 1
 415 #ifdef _DEBUG_HOMARD_
 416       write (ulsort,texte(langue,3)) 'CMCPYA pyra 1', nompro
 417 #endif
 418       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 419      >              areint(2), areint(1), areint(4), areint(3),
 420      >              listar(9), listar(11), listar(12), listar(10),
 421      >              iaux,  nufami,   indpyr )
 422 c
 423 c 5.2. ==> Pyramides s'appuyant sur la face decoupee
 424 c
 425       indpyr = indpyr + 1
 426 #ifdef _DEBUG_HOMARD_
 427       write (ulsort,texte(langue,3)) 'CMCPYA pyra 2', nompro
 428 #endif
 429       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 430      >              listar(5), as6n2, areint(2), as6n1,
 431      >              as1n2, an2nf1, an1nf1, as1n1,
 432      >              iaux,  nufami,   indpyr )
 433 c
 434       indpyr = indpyr + 1
 435 #ifdef _DEBUG_HOMARD_
 436       write (ulsort,texte(langue,3)) 'CMCPYA pyra 3', nompro
 437 #endif
 438       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 439      >              listar(7), as7n4, areint(3), as7n2,
 440      >              as4n4, an4nf1, an2nf1, as4n2,
 441      >              iaux,  nufami,   indpyr )
 442 c
 443       indpyr = indpyr + 1
 444 #ifdef _DEBUG_HOMARD_
 445       write (ulsort,texte(langue,3)) 'CMCPYA pyra 4', nompro
 446 #endif
 447       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 448      >              listar(8), as8n3, areint(4), as8n4,
 449      >              as3n3, an3nf1, an4nf1, as3n4,
 450      >              iaux,  nufami,   indpyr )
 451 c
 452       indpyr = indpyr + 1
 453 #ifdef _DEBUG_HOMARD_
 454       write (ulsort,texte(langue,3)) 'CMCPYA pyra 5', nompro
 455 #endif
 456       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 457      >              listar(6), as5n1, areint(1), as5n3,
 458      >              as2n1, an1nf1, an3nf1, as2n3,
 459      >              iaux,  nufami,   indpyr )
 460 c
 461 c====
 462 c 6. Creation des 4 tetraedres
 463 c====
 464 c
 465       nufami = cfahex(coftfh,famhex(lehexa))
 466 c
 467       indtet = indtet + 1
 468 #ifdef _DEBUG_HOMARD_
 469       write (ulsort,texte(langue,3)) 'CMCTEA - tetra 1', nompro
 470 #endif
 471       call cmctea ( aretet, famtet, hettet, filtet, pertet,
 472      >              an1nf1, areint(1), areint(2), as5n1,
 473      >              as6n1, listar(9),
 474      >              iaux,  nufami,   indtet )
 475 c
 476       indtet = indtet + 1
 477 #ifdef _DEBUG_HOMARD_
 478       write (ulsort,texte(langue,3)) 'CMCTEA - tetra 2', nompro
 479 #endif
 480       call cmctea ( aretet, famtet, hettet, filtet, pertet,
 481      >              an2nf1, areint(2), areint(3), as6n2,
 482      >              as7n2, listar(10),
 483      >              iaux,  nufami,   indtet )
 484 c
 485       indtet = indtet + 1
 486 #ifdef _DEBUG_HOMARD_
 487       write (ulsort,texte(langue,3)) 'CMCTEA - tetra 3', nompro
 488 #endif
 489       call cmctea ( aretet, famtet, hettet, filtet, pertet,
 490      >              an4nf1, areint(3), areint(4), as7n4,
 491      >              as8n4, listar(12),
 492      >              iaux,  nufami,   indtet )
 493 c
 494       indtet = indtet + 1
 495 #ifdef _DEBUG_HOMARD_
 496       write (ulsort,texte(langue,3)) 'CMCTEA - tetra 4', nompro
 497 #endif
 498       call cmctea ( aretet, famtet, hettet, filtet, pertet,
 499      >              an3nf1, areint(4), areint(1), as8n3,
 500      >              as5n3, listar(11),
 501      >              iaux,  nufami,   indtet )
 502 c
 503 c====
 504 c 5. la fin
 505 c====
 506 c
 507       if ( codret.ne.0 ) then
 508 c
 509 #include "envex2.h"
 510 c
 511       write (ulsort,texte(langue,1)) 'Sortie', nompro
 512       write (ulsort,texte(langue,2)) codret
 513 c
 514       endif
 515 c
 516 #ifdef _DEBUG_HOMARD_
 517       write (ulsort,texte(langue,1)) 'Sortie', nompro
 518       call dmflsh (iaux)
 519 #endif
 520 c
 521       end