src/tool/Creation_Maillage/cmh413.F

   1       subroutine cmh413 ( 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 ='CMH413' )
 110       parameter ( nbarin = 13 )
 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 4 aretes coupees
 203 c    . du noeud milieu de la face coupee en 3 quadrangles
 204 c====
 205 c
 206       do 21 , iaux = 1 , 8
 207         lesnoe(iaux) = listso(iaux)
 208    21 continue
 209 c
 210       lesnoe(9) = somare(2,filare(listar(1)))
 211       lesnoe(10) = somare(2,filare(listar(2)))
 212       lesnoe(11) = somare(2,filare(listar(10)))
 213       lesnoe(12) = somare(2,filare(listar(11)))
 214 c
 215       iaux = filqua(listfa(1))
 216       lesnoe(13) = somare(2,arequa(iaux,4))
 217 #ifdef _DEBUG_HOMARD_
 218       do 2000 , iaux = 1 , nbarin
 219         write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux)
 220  2000 continue
 221 #endif
 222 c
 223 c====
 224 c 3. Creation du noeud interne et des treize aretes internes
 225 c====
 226 c
 227 #ifdef _DEBUG_HOMARD_
 228       write (ulsort,texte(langue,3)) 'CMCHPB', nompro
 229 #endif
 230       call cmchpb ( indnoe, indare, nbarin,
 231      >              nbsomm, lesnoe, areint,
 232      >              coonoe, hetnoe, arenoe,
 233      >              famnoe,
 234      >              hetare, somare,
 235      >              filare, merare, famare,
 236      >              ulsort, langue, codret )
 237 c
 238 c====
 239 c 4. Creation des huit pyramides et des six tetraedres
 240 c====
 241 c
 242       iaux = -indptp
 243       jaux = cfahex(cofpfh,famhex(lehexa))
 244 c
 245 c 4.1. ==> Sur la face 1
 246 c
 247       liarin(1) = areint(1)
 248       liarin(2) = areint(4)
 249       liarin(3) = areint(3)
 250       liarin(4) = areint(2)
 251       liarin(5) = areint(10)
 252       liarin(6) = areint(9)
 253       liarin(7) = areint(13)
 254       fdcode = listcf(1)
 255       fdnume = listfa(1)
 256 c
 257 #ifdef _DEBUG_HOMARD_
 258       write (ulsort,texte(langue,3)) 'CMCPY3 - face 1', nompro
 259 #endif
 260       call cmcpy3 ( lehexa, indpyr, indptp,
 261      >              fdnume, fdcode,
 262      >              liarin,
 263      >              arequa, filqua,
 264      >              arepyr, fampyr,
 265      >              hetpyr, filpyr, perpyr,
 266      >              famhex, cfahex,
 267      >              ulsort, langue, codret )
 268 c
 269 c 4.2. ==> Sur la face 2
 270 c
 271       liarin(1) = areint(2)
 272       liarin(2) = areint(5)
 273       liarin(3) = areint(6)
 274       liarin(4) = areint(1)
 275       liarin(5) = areint(9)
 276       fdnume = listfa(2)
 277       fdcode = listcf(2)
 278 c
 279 #ifdef _DEBUG_HOMARD_
 280       write (ulsort,texte(langue,3)) 'CMCTE3 - face 2', nompro
 281 #endif
 282       call cmcte3 ( lehexa, indtet, indptp,
 283      >              fdnume, fdcode, liarin,
 284      >              aretri, filqua,
 285      >              aretet, famtet,
 286      >              hettet, filtet, pertet,
 287      >              famhex, cfahex,
 288      >              ulsort, langue, codret )
 289 c
 290 c 4.3. ==> Sur la face 3
 291 c
 292       lisomm(1) = lesnoe(1)
 293       liarin(1) = areint(1)
 294       lisomm(2) = lesnoe(6)
 295       liarin(2) = areint(6)
 296       lisomm(3) = lesnoe(7)
 297       liarin(3) = areint(7)
 298       lisomm(4) = lesnoe(4)
 299       liarin(4) = areint(4)
 300       liarin(5) = areint(10)
 301       liarin(6) = areint(11)
 302       are1 = listar(2)
 303       are2 = listar(5)
 304       are3 = listar(10)
 305       are4 = listar(7)
 306       fdnume = listfa(3)
 307 c
 308 #ifdef _DEBUG_HOMARD_
 309       write (ulsort,texte(langue,3)) 'CMCPY2 - face 3', nompro
 310 #endif
 311       call cmcpy2 ( lehexa, indpyr, indptp,
 312      >              fdnume,
 313      >              lisomm, liarin,
 314      >              are1, are2, are3, are4,
 315      >              filare, arequa, filqua,
 316      >              arepyr, fampyr,
 317      >              hetpyr, filpyr, perpyr,
 318      >              famhex, cfahex,
 319      >              ulsort, langue, codret )
 320 c
 321 c 4.4. ==> Sur la face 4
 322 c
 323       liarin(1) = areint(5)
 324       liarin(2) = areint(2)
 325       liarin(3) = areint(3)
 326       liarin(4) = areint(8)
 327       liarin(5) = areint(12)
 328       fdnume = listfa(4)
 329       fdcode = listcf(4)
 330 c
 331 #ifdef _DEBUG_HOMARD_
 332       write (ulsort,texte(langue,3)) 'CMCTE3 - face 4', nompro
 333 #endif
 334       call cmcte3 ( lehexa, indtet, indptp,
 335      >              fdnume, fdcode, liarin,
 336      >              aretri, filqua,
 337      >              aretet, famtet,
 338      >              hettet, filtet, pertet,
 339      >              famhex, cfahex,
 340      >              ulsort, langue, codret )
 341 c
 342 c 4.5. ==> Sur la face 5
 343 c
 344       are1 = areint(3)
 345       are2 = areint(4)
 346       are3 = areint(7)
 347       are4 = areint(8)
 348       are5 = listar(4)
 349       are6 = listar(7)
 350       are7 = listar(12)
 351       are8 = listar(8)
 352       indpyr = indpyr + 1
 353 #ifdef _DEBUG_HOMARD_
 354       write (ulsort,texte(langue,3)) 'CMCPYA - face 5', nompro
 355 #endif
 356       call cmcpya ( arepyr, fampyr, hetpyr, filpyr, perpyr,
 357      >              are1, are2, are3, are4,
 358      >              are5, are6, are7, are8,
 359      >              iaux,  jaux,   indpyr )
 360 c
 361 c 4.6. ==> Sur la face 6
 362 c
 363       lisomm(1) = lesnoe(8)
 364       liarin(1) = areint(8)
 365       lisomm(2) = lesnoe(7)
 366       liarin(2) = areint(7)
 367       lisomm(3) = lesnoe(6)
 368       liarin(3) = areint(6)
 369       lisomm(4) = lesnoe(5)
 370       liarin(4) = areint(5)
 371       liarin(5) = areint(12)
 372       liarin(6) = areint(11)
 373       are1 = listar(11)
 374       are2 = listar(12)
 375       are3 = listar(10)
 376       are4 = listar(9)
 377       fdnume = listfa(6)
 378 c
 379 #ifdef _DEBUG_HOMARD_
 380       write (ulsort,texte(langue,3)) 'CMCPY2 - face 6', nompro
 381 #endif
 382       call cmcpy2 ( lehexa, indpyr, indptp,
 383      >              fdnume,
 384      >              lisomm, liarin,
 385      >              are1, are2, are3, are4,
 386      >              filare, arequa, filqua,
 387      >              arepyr, fampyr,
 388      >              hetpyr, filpyr, perpyr,
 389      >              famhex, cfahex,
 390      >              ulsort, langue, codret )
 391 c
 392 c====
 393 c 5. la fin
 394 c====
 395 c
 396       if ( codret.ne.0 ) then
 397 c
 398 #include "envex2.h"
 399 c
 400       write (ulsort,texte(langue,1)) 'Sortie', nompro
 401       write (ulsort,texte(langue,2)) codret
 402 c
 403       endif
 404 c
 405 #ifdef _DEBUG_HOMARD_
 406       write (ulsort,texte(langue,1)) 'Sortie', nompro
 407       call dmflsh (iaux)
 408 #endif
 409 c
 410       end