src/tool/Creation_Maillage/cmh900.F

   1       subroutine cmh900 ( 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 ='CMH900' )
 110       parameter ( nbarin = 23 )
 111 c
 112       integer nbsomm
 113       parameter ( nbsomm = 8 )
 114 c
 115 #include "nblang.h"
 116 #include "cofpfh.h"
 117 c
 118 c 0.2. ==> communs
 119 c
 120 #include "envex1.h"
 121 c
 122 #include "envca1.h"
 123 #include "dicfen.h"
 124 #include "nbfami.h"
 125 #include "nouvnb.h"
 126 c
 127 c 0.3. ==> arguments
 128 c
 129       integer lehexa
 130       integer indnoe, indare, indtet, indpyr, indhex
 131       integer indptp
 132       integer listso(8), listar(12), listfa(6), listcf(6)
 133       integer hetnoe(nouvno), arenoe(nouvno)
 134       integer famnoe(nouvno)
 135       integer hetare(nouvar), somare(2,nouvar)
 136       integer filare(nouvar), merare(nouvar), famare(nouvar)
 137       integer aretri(nouvtr,3)
 138       integer arequa(nouvqu,4)
 139       integer filqua(nouvqu)
 140       integer hettet(nouvte), aretet(nouvta,6)
 141       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 142       integer hetpyr(nouvpy), arepyr(nouvya,8)
 143       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 144       integer arehex(nouvha,12)
 145       integer hethex(nouvhe)
 146       integer filhex(nouvhe), perhex(nouvhe)
 147       integer cfahex(nctfhe,nbfhex), famhex(nouvhe)
 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 iaux, jaux
 156 c
 157       integer lesnoe(nbarin), areint(nbarin)
 158       integer lisomm(10), liarin(10)
 159       integer fdnume, fdcode
 160       integer are1, are2, are3, are4
 161       integer are5, are6, are7, are8
 162
 163 c
 164       integer nbmess
 165       parameter ( nbmess = 10 )
 166       character*80 texte(nblang,nbmess)
 167 c
 168 c 0.5. ==> initialisations
 169 c ______________________________________________________________________
 170 c
 171 c====
 172 c 1. messages
 173 c====
 174 c
 175 #include "impr01.h"
 176 #include "impr03.h"
 177 c
 178 #ifdef _DEBUG_HOMARD_
 179       write (ulsort,texte(langue,1)) 'Entree', nompro
 180       call dmflsh (iaux)
 181 #endif
 182 c
 183 #ifdef _DEBUG_HOMARD_
 184       write (ulsort,90002) 'indnoe', indnoe
 185       write (ulsort,90002) 'indtet', indtet
 186       write (ulsort,90002) 'indpyr', indpyr
 187       write (ulsort,90002) 'indhex', indhex
 188 #endif
 189 #ifdef _DEBUG_HOMARD_
 190       write (ulsort,90002) 'listar  1-8', (listar(iaux),iaux=1,8)
 191       write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12)
 192       write (ulsort,90002) 'listso', listso
 193       write (ulsort,90002) 'listfa', listfa
 194       write (ulsort,90002) 'listcf', listcf
 195 #endif
 196 c
 197       codret = 0
 198 c
 199 c====
 200 c 2. Recuperation
 201 c    . des sommets de l'hexaedre
 202 c    . des noeuds milieux des 9 aretes coupees
 203 c    . des noeuds milieux des 3 faces coupees en 3 quadrangles
 204 c    . des noeuds milieux des 3 faces coupees en 4 quadrangles
 205 c====
 206 c
 207       do 21 , iaux = 1 , 8
 208         lesnoe(iaux) = listso(iaux)
 209    21 continue
 210 c
 211       lesnoe(9) = somare(2,filare(listar(1)))
 212       lesnoe(10) = somare(2,filare(listar(2)))
 213       lesnoe(11) = somare(2,filare(listar(3)))
 214       lesnoe(12) = somare(2,filare(listar(4)))
 215       lesnoe(13) = somare(2,filare(listar(5)))
 216       lesnoe(14) = somare(2,filare(listar(6)))
 217       lesnoe(15) = somare(2,filare(listar(7)))
 218       lesnoe(16) = somare(2,filare(listar(9)))
 219       lesnoe(17) = somare(2,filare(listar(10)))
 220 c
 221       iaux = filqua(listfa(1))
 222       lesnoe(18) = somare(2,arequa(iaux,2))
 223       iaux = filqua(listfa(2))
 224       lesnoe(19) = somare(2,arequa(iaux,2))
 225       iaux = filqua(listfa(3))
 226       lesnoe(20) = somare(2,arequa(iaux,2))
 227       iaux = filqua(listfa(4))
 228       lesnoe(21) = somare(2,arequa(iaux,4))
 229       iaux = filqua(listfa(5))
 230       lesnoe(22) = somare(2,arequa(iaux,4))
 231       iaux = filqua(listfa(6))
 232       lesnoe(23) = somare(2,arequa(iaux,4))
 233 #ifdef _DEBUG_HOMARD_
 234       do 2000 , iaux = 1 , nbarin
 235         write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux)
 236  2000 continue
 237 #endif
 238 c
 239 c====
 240 c 3. Creation du noeud interne et des vingt-trois aretes internes
 241 c====
 242 c
 243 #ifdef _DEBUG_HOMARD_
 244       write (ulsort,texte(langue,3)) 'CMCHPB', nompro
 245 #endif
 246       call cmchpb ( indnoe, indare, nbarin,
 247      >              nbsomm, lesnoe, areint,
 248      >              coonoe, hetnoe, arenoe,
 249      >              famnoe,
 250      >              hetare, somare,
 251      >              filare, merare, famare,
 252      >              ulsort, langue, codret )
 253 c
 254 c====
 255 c 4. Creation des vingt et une pyramides
 256 c====
 257 c
 258       iaux = -indptp
 259       jaux = cfahex(cofpfh,famhex(lehexa))
 260 c
 261 c 4.1. ==> Sur la face 1
 262 c
 263       lisomm(1) = lesnoe(2)
 264       liarin(1) = areint(2)
 265       lisomm(2) = lesnoe(1)
 266       liarin(2) = areint(1)
 267       lisomm(3) = lesnoe(4)
 268       liarin(3) = areint(4)
 269       lisomm(4) = lesnoe(3)
 270       liarin(4) = areint(3)
 271       liarin(5) = areint(9)
 272       liarin(6) = areint(10)
 273       liarin(7) = areint(12)
 274       liarin(8) = areint(11)
 275       liarin(9) = areint(18)
 276       lisomm(5) = lesnoe(9)
 277       lisomm(6) = lesnoe(10)
 278       lisomm(7) = lesnoe(12)
 279       lisomm(8) = lesnoe(11)
 280       are1 = listar(1)
 281       are2 = listar(2)
 282       are3 = listar(4)
 283       are4 = listar(3)
 284       fdnume = listfa(1)
 285 c
 286 #ifdef _DEBUG_HOMARD_
 287       write (ulsort,texte(langue,3)) 'CMCPY4 - face 1', nompro
 288 #endif
 289       call cmcpy4 ( lehexa, indpyr, indptp,
 290      >              fdnume,
 291      >              lisomm, liarin, are1, are2, are3, are4,
 292      >              somare, filare, arequa, filqua,
 293      >              arepyr, fampyr,
 294      >              hetpyr, filpyr, perpyr,
 295      >              famhex, cfahex,
 296      >              ulsort, langue, codret )
 297 c
 298 c 4.2. ==> Sur la face 2
 299 c
 300       lisomm(1) = lesnoe(1)
 301       liarin(1) = areint(1)
 302       lisomm(2) = lesnoe(2)
 303       liarin(2) = areint(2)
 304       lisomm(3) = lesnoe(5)
 305       liarin(3) = areint(5)
 306       lisomm(4) = lesnoe(6)
 307       liarin(4) = areint(6)
 308       liarin(5) = areint(9)
 309       liarin(6) = areint(14)
 310       liarin(7) = areint(16)
 311       liarin(8) = areint(13)
 312       liarin(9) = areint(19)
 313       lisomm(5) = lesnoe(9)
 314       lisomm(6) = lesnoe(14)
 315       lisomm(7) = lesnoe(16)
 316       lisomm(8) = lesnoe(13)
 317       are1 = listar(1)
 318       are2 = listar(6)
 319       are3 = listar(9)
 320       are4 = listar(5)
 321       fdnume = listfa(2)
 322 c
 323 #ifdef _DEBUG_HOMARD_
 324       write (ulsort,texte(langue,3)) 'CMCPY4 - face 2', nompro
 325 #endif
 326       call cmcpy4 ( lehexa, indpyr, indptp,
 327      >              fdnume,
 328      >              lisomm, liarin, are1, are2, are3, are4,
 329      >              somare, filare, arequa, filqua,
 330      >              arepyr, fampyr,
 331      >              hetpyr, filpyr, perpyr,
 332      >              famhex, cfahex,
 333      >              ulsort, langue, codret )
 334 c
 335 c 4.3. ==> Sur la face 3
 336 c
 337       lisomm(1) = lesnoe(1)
 338       liarin(1) = areint(1)
 339       lisomm(2) = lesnoe(6)
 340       liarin(2) = areint(6)
 341       lisomm(3) = lesnoe(7)
 342       liarin(3) = areint(7)
 343       lisomm(4) = lesnoe(4)
 344       liarin(4) = areint(4)
 345       liarin(5) = areint(13)
 346       liarin(6) = areint(17)
 347       liarin(7) = areint(15)
 348       liarin(8) = areint(10)
 349       liarin(9) = areint(20)
 350       lisomm(5) = lesnoe(13)
 351       lisomm(6) = lesnoe(17)
 352       lisomm(7) = lesnoe(15)
 353       lisomm(8) = lesnoe(10)
 354       are1 = listar(5)
 355       are2 = listar(10)
 356       are3 = listar(7)
 357       are4 = listar(2)
 358       fdnume = listfa(3)
 359 c
 360 #ifdef _DEBUG_HOMARD_
 361       write (ulsort,texte(langue,3)) 'CMCPY4 - face 3', nompro
 362 #endif
 363       call cmcpy4 ( lehexa, indpyr, indptp,
 364      >              fdnume,
 365      >              lisomm, liarin, are1, are2, are3, are4,
 366      >              somare, filare, arequa, filqua,
 367      >              arepyr, fampyr,
 368      >              hetpyr, filpyr, perpyr,
 369      >              famhex, cfahex,
 370      >              ulsort, langue, codret )
 371 c
 372 c 4.4. ==> Sur la face 4
 373 c
 374       liarin(1) = areint(2)
 375       liarin(2) = areint(3)
 376       liarin(3) = areint(8)
 377       liarin(4) = areint(5)
 378       liarin(5) = areint(11)
 379       liarin(6) = areint(14)
 380       liarin(7) = areint(21)
 381       fdcode = listcf(4)
 382       fdnume = listfa(4)
 383 c
 384 #ifdef _DEBUG_HOMARD_
 385       write (ulsort,texte(langue,3)) 'CMCPY3 - face 4', nompro
 386 #endif
 387       call cmcpy3 ( lehexa, indpyr, indptp,
 388      >              fdnume, fdcode,
 389      >              liarin,
 390      >              arequa, filqua,
 391      >              arepyr, fampyr,
 392      >              hetpyr, filpyr, perpyr,
 393      >              famhex, cfahex,
 394      >              ulsort, langue, codret )
 395 c
 396 c 4.5. ==> Sur la face 5
 397 c
 398       liarin(1) = areint(4)
 399       liarin(2) = areint(7)
 400       liarin(3) = areint(8)
 401       liarin(4) = areint(3)
 402       liarin(5) = areint(15)
 403       liarin(6) = areint(12)
 404       liarin(7) = areint(22)
 405       fdcode = listcf(5)
 406       fdnume = listfa(5)
 407 c
 408 #ifdef _DEBUG_HOMARD_
 409       write (ulsort,texte(langue,3)) 'CMCPY3 - face 5', nompro
 410 #endif
 411       call cmcpy3 ( lehexa, indpyr, indptp,
 412      >              fdnume, fdcode,
 413      >              liarin,
 414      >              arequa, filqua,
 415      >              arepyr, fampyr,
 416      >              hetpyr, filpyr, perpyr,
 417      >              famhex, cfahex,
 418      >              ulsort, langue, codret )
 419 c
 420 c 4.6. ==> Sur la face 6
 421 c
 422       liarin(1) = areint(6)
 423       liarin(2) = areint(5)
 424       liarin(3) = areint(8)
 425       liarin(4) = areint(7)
 426       liarin(5) = areint(16)
 427       liarin(6) = areint(17)
 428       liarin(7) = areint(23)
 429       fdcode = listcf(6)
 430       fdnume = listfa(6)
 431 c
 432 #ifdef _DEBUG_HOMARD_
 433       write (ulsort,texte(langue,3)) 'CMCPY3 - face 6', nompro
 434 #endif
 435       call cmcpy3 ( lehexa, indpyr, indptp,
 436      >              fdnume, fdcode,
 437      >              liarin,
 438      >              arequa, filqua,
 439      >              arepyr, fampyr,
 440      >              hetpyr, filpyr, perpyr,
 441      >              famhex, cfahex,
 442      >              ulsort, langue, codret )
 443 c
 444 c====
 445 c 5. la fin
 446 c====
 447 c
 448       if ( codret.ne.0 ) then
 449 c
 450 #include "envex2.h"
 451 c
 452       write (ulsort,texte(langue,1)) 'Sortie', nompro
 453       write (ulsort,texte(langue,2)) codret
 454 c
 455       endif
 456 c
 457 #ifdef _DEBUG_HOMARD_
 458       write (ulsort,texte(langue,1)) 'Sortie', nompro
 459       call dmflsh (iaux)
 460 #endif
 461 c
 462       end