src/tool/Creation_Maillage/cmch88.F

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