src/tool/Creation_Maillage/cmh800.F

   1       subroutine cmh800 ( 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 ='CMH800' )
 110       parameter ( nbarin = 18 )
 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       integer listaf(4)
 164       integer as1n1, as2n1, as1n2, as4n2
 165       integer as3n4, as4n4, as2n3, as3n3
 166       integer an1nf1, an2nf1, an4nf1, an3nf1
 167       integer as5n9, as6n9, as6n10, as7n10
 168       integer as7n12, as8n12, as8n11, as5n11
 169       integer an9f6, an10f6, an11f6, an12f6
 170       integer an1n9, an2n10, an3n11, an4n12
 171       integer af1f6
 172 c
 173       integer nbmess
 174       parameter ( nbmess = 10 )
 175       character*80 texte(nblang,nbmess)
 176 c
 177 c 0.5. ==> initialisations
 178 c ______________________________________________________________________
 179 c
 180 c====
 181 c 1. messages
 182 c====
 183 c
 184 #include "impr01.h"
 185 #include "impr03.h"
 186 c
 187 #ifdef _DEBUG_HOMARD_
 188       write (ulsort,texte(langue,1)) 'Entree', nompro
 189       call dmflsh (iaux)
 190 #endif
 191 c
 192 #ifdef _DEBUG_HOMARD_
 193       write (ulsort,90002) 'indnoe', indnoe
 194       write (ulsort,90002) 'indtet', indtet
 195       write (ulsort,90002) 'indpyr', indpyr
 196       write (ulsort,90002) 'indhex', indhex
 197 #endif
 198 #ifdef _DEBUG_HOMARD_
 199       write (ulsort,90002) 'listar  1-8', (listar(iaux),iaux=1,8)
 200       write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12)
 201       write (ulsort,90002) 'listso', listso
 202       write (ulsort,90002) 'listfa', listfa
 203       write (ulsort,90002) 'listcf', listcf
 204 #endif
 205 c
 206       codret = 0
 207 c
 208 c====
 209 c 2. Recuperation
 210 c    . des sommets de l'hexaedre
 211 c    . des noeuds milieux des 8 aretes coupees
 212 c    . des noeuds milieux des 2 faces coupees en 4 quadrangles
 213 c====
 214 c
 215       do 21 , iaux = 1 , 8
 216         lesnoe(iaux) = listso(iaux)
 217    21 continue
 218 c
 219       lesnoe(9) = somare(2,filare(listar(1)))
 220       lesnoe(10) = somare(2,filare(listar(2)))
 221       lesnoe(11) = somare(2,filare(listar(3)))
 222       lesnoe(12) = somare(2,filare(listar(4)))
 223       lesnoe(13) = somare(2,filare(listar(9)))
 224       lesnoe(14) = somare(2,filare(listar(10)))
 225       lesnoe(15) = somare(2,filare(listar(11)))
 226       lesnoe(16) = somare(2,filare(listar(12)))
 227 c
 228       iaux = filqua(listfa(1))
 229       lesnoe(17) = somare(2,arequa(iaux,2))
 230       iaux = filqua(listfa(6))
 231       lesnoe(18) = somare(2,arequa(iaux,2))
 232 #ifdef _DEBUG_HOMARD_
 233       do 2000 , iaux = 1 , nbarin
 234         write(ulsort,90015) 'lesnoe(',iaux,') = ', lesnoe(iaux)
 235  2000 continue
 236 #endif
 237 c
 238 c====
 239 c 3. Recuperation des demi-aretes de la face f1
 240 c====
 241 c 3.1. ==> Filles des aretes de bord
 242 c 3.1.1. == filles de listar(1)
 243 c
 244       if ( lesnoe(2).le.lesnoe(1) ) then
 245         as1n1 = filare(listar(1)) + 1
 246         as2n1 = filare(listar(1))
 247       else
 248         as1n1 = filare(listar(1))
 249         as2n1 = filare(listar(1)) + 1
 250       endif
 251 c
 252 c 3.1.2. == filles de listar(2)
 253 c
 254       if ( lesnoe(1).le.lesnoe(4) ) then
 255         as1n2 = filare(listar(2))
 256         as4n2 = filare(listar(2)) + 1
 257       else
 258         as1n2 = filare(listar(2)) + 1
 259         as4n2 = filare(listar(2))
 260       endif
 261 c
 262 c 3.1.3. == filles de listar(4)
 263 c
 264       if ( lesnoe(4).le.lesnoe(3) ) then
 265         as3n4 = filare(listar(4)) + 1
 266         as4n4 = filare(listar(4))
 267       else
 268         as3n4 = filare(listar(4))
 269         as4n4 = filare(listar(4)) + 1
 270       endif
 271 c
 272 c 3.1.4. == filles de listar(3)
 273 c
 274       if ( lesnoe(3).le.lesnoe(2) ) then
 275         as2n3 = filare(listar(3)) + 1
 276         as3n3 = filare(listar(3))
 277       else
 278         as2n3 = filare(listar(3))
 279         as3n3 = filare(listar(3)) + 1
 280       endif
 281 c
 282 #ifdef _DEBUG_HOMARD_
 283       write (ulsort,90002) 'as1n1, as2n1, as1n2, as4n2',
 284      >                      as1n1, as2n1, as1n2, as4n2
 285       write (ulsort,90002) 'as3n4, as4n4, as2n3, as3n3',
 286      >                      as3n4, as4n4, as2n3, as3n3
 287 #endif
 288 c
 289 c 3.2. Recuperation des aretes entre les milieux des aretes coupees
 290 c 3.2.1. ==> Recuperation des aretes : ce sont les 2eme et 3eme dans
 291 c            la description des fils (cf. cmcdq2)
 292 c
 293       listaf(1) = arequa(filqua(listfa(1))  ,2)
 294       listaf(2) = arequa(filqua(listfa(1))  ,3)
 295       listaf(3) = arequa(filqua(listfa(1))+2,2)
 296       listaf(4) = arequa(filqua(listfa(1))+2,3)
 297 #ifdef _DEBUG_HOMARD_
 298       write (ulsort,90002) 'listaf', listaf
 299 #endif
 300 c
 301 c 3.2.2. ==> Positionnement
 302 c
 303       do 322 , iaux = 1 , 4
 304 c
 305         jaux = somare(1,listaf(iaux))
 306         if ( jaux.eq.lesnoe(9) ) then
 307           an1nf1 = listaf(iaux)
 308         elseif ( jaux.eq.lesnoe(10) ) then
 309           an2nf1 = listaf(iaux)
 310         elseif ( jaux.eq.lesnoe(12) ) then
 311           an4nf1 = listaf(iaux)
 312         elseif ( jaux.eq.lesnoe(11) ) then
 313           an3nf1 = listaf(iaux)
 314         endif
 315 c
 316   322 continue
 317 c
 318 #ifdef _DEBUG_HOMARD_
 319       write (ulsort,90002) 'an1nf1, an2nf1, an4nf1, an3nf1',
 320      >                      an1nf1, an2nf1, an4nf1, an3nf1
 321 #endif
 322 c
 323 c====
 324 c 4. Recuperation des demi-aretes de la face f6
 325 c====
 326 c 4.1. ==> Filles des aretes de bord
 327 c 4.1.1. == filles de listar(9)
 328 c
 329       if ( lesnoe(5).le.lesnoe(6) ) then
 330         as5n9 = filare(listar(9))
 331         as6n9 = filare(listar(9)) + 1
 332       else
 333         as5n9 = filare(listar(9)) + 1
 334         as6n9 = filare(listar(9))
 335       endif
 336 c
 337 c 4.1.2. == filles de listar(10)
 338 c
 339       if ( lesnoe(6).le.lesnoe(7) ) then
 340         as6n10 = filare(listar(10))
 341         as7n10 = filare(listar(10)) + 1
 342       else
 343         as6n10 = filare(listar(10)) + 1
 344         as7n10 = filare(listar(10))
 345       endif
 346 c
 347 c 4.1.3. == filles de listar(12)
 348 c
 349       if ( lesnoe(7).le.lesnoe(8) ) then
 350         as7n12 = filare(listar(12))
 351         as8n12 = filare(listar(12))+ 1
 352       else
 353         as7n12 = filare(listar(12))+ 1
 354         as8n12 = filare(listar(12))
 355       endif
 356 c
 357 c 4.1.4. == filles de listar(11)
 358 c
 359       if ( lesnoe(5).le.lesnoe(8) ) then
 360         as5n11 = filare(listar(11))
 361         as8n11 = filare(listar(11))+ 1
 362       else
 363         as5n11 = filare(listar(11))+ 1
 364         as8n11 = filare(listar(11))
 365       endif
 366 c
 367 #ifdef _DEBUG_HOMARD_
 368       write (ulsort,90002) 'as5n9, as6n9, as6n10, as7n10',
 369      >                      as5n9, as6n9, as6n10, as7n10
 370       write (ulsort,90002) 'as7n12, as8n12, as8n11, as5n11',
 371      >                      as7n12, as8n12, as8n11, as5n11
 372 #endif
 373 c
 374 c 4.2. Recuperation des aretes entre les milieux des aretes coupees
 375 c 4.2.1. ==> Recuperation des aretes : ce sont les 2eme et 3eme dans
 376 c            la description des fils (cf. cmcdq2)
 377 c
 378       listaf(1) = arequa(filqua(listfa(6))  ,2)
 379       listaf(2) = arequa(filqua(listfa(6))  ,3)
 380       listaf(3) = arequa(filqua(listfa(6))+2,2)
 381       listaf(4) = arequa(filqua(listfa(6))+2,3)
 382 #ifdef _DEBUG_HOMARD_
 383       write (ulsort,90002) 'listaf', listaf
 384 #endif
 385 c
 386 c 4.2.2. ==> Positionnement
 387 c
 388       do 422 , iaux = 1 , 4
 389 c
 390         jaux = somare(1,listaf(iaux))
 391         if ( jaux.eq.lesnoe(13) ) then
 392           an9f6 = listaf(iaux)
 393         elseif ( jaux.eq.lesnoe(14) ) then
 394           an10f6 = listaf(iaux)
 395         elseif ( jaux.eq.lesnoe(15) ) then
 396           an11f6 = listaf(iaux)
 397         elseif ( jaux.eq.lesnoe(16) ) then
 398           an12f6 = listaf(iaux)
 399         endif
 400 c
 401   422 continue
 402 c
 403 #ifdef _DEBUG_HOMARD_
 404       write (ulsort,90002) 'an9f6, an10f6, an11f6, an12f6',
 405      >                      an9f6, an10f6, an11f6, an12f6
 406 #endif
 407 c
 408 c====
 409 c 5. Aretes sur les faces coupees en 2
 410 c    C'est toujours la 4eme dans la description des fils (cf. cmcdq2)
 411 c====
 412 c
 413       an1n9 = arequa(filqua(listfa(2)),4)
 414       an2n10 = arequa(filqua(listfa(3)),4)
 415       an3n11 = arequa(filqua(listfa(4)),4)
 416       an4n12 = arequa(filqua(listfa(5)),4)
 417 c
 418 #ifdef _DEBUG_HOMARD_
 419       write (ulsort,90002) 'an1n9, an2n10, an3n11, an4n12',
 420      >                      an1n9, an2n10, an3n11, an4n12
 421 #endif
 422 c
 423 c====
 424 c 6. Creation de l'arete interne
 425 c====
 426 c
 427       indare = indare + 1
 428 c
 429       af1f6 = indare
 430       somare(1,af1f6) = min ( lesnoe(17) , lesnoe(18) )
 431       somare(2,af1f6) = max ( lesnoe(17) , lesnoe(18) )
 432 c
 433       famare(af1f6) = 1
 434       hetare(af1f6) = 50
 435       merare(af1f6) = 0
 436       filare(af1f6) = 0
 437 c
 438 #ifdef _DEBUG_HOMARD_
 439       write (ulsort,90002) 'af1f6', af1f6
 440 #endif
 441 c
 442 c====
 443 c 7. Creation des hexaedres
 444 c====
 445 c
 446       jaux = cfahex(cofpfh,famhex(lehexa))
 447 c
 448 c 7.1. ==> Contenant l'arete A5
 449 c
 450       indhex = indhex + 1
 451       call cmchea ( arehex, famhex,
 452      >              hethex, filhex, perhex,
 453      >              as1n1, as1n2, an1nf1, an2nf1,
 454      >              listar(5), an1n9, an2n10, af1f6,
 455      >              as6n9, as6n10, an9f6, an10f6,
 456      >              lehexa, jaux, indhex )
 457 c
 458       filhex(lehexa) = indhex
 459 c
 460 c 7.2. ==> Contenant l'arete A7
 461 c
 462       indhex = indhex + 1
 463       call cmchea ( arehex, famhex,
 464      >              hethex, filhex, perhex,
 465      >              an2nf1, as4n2, an4nf1, as4n4,
 466      >              an2n10, af1f6, listar(7), an4n12,
 467      >              an10f6, as7n10, an12f6, as7n12,
 468      >              lehexa, jaux, indhex )
 469 c
 470 c 7.3. ==> Contenant l'arete A8
 471 c
 472       indhex = indhex + 1
 473       call cmchea ( arehex, famhex,
 474      >              hethex, filhex, perhex,
 475      >              an3nf1, an4nf1, as3n3, as3n4,
 476      >              af1f6, an3n11, an4n12, listar(8),
 477      >              an11f6, an12f6, as8n11, as8n12,
 478      >              lehexa, jaux, indhex )
 479 c
 480 c 7.4. ==> Contenant l'arete A6
 481 c
 482       indhex = indhex + 1
 483       call cmchea ( arehex, famhex,
 484      >              hethex, filhex, perhex,
 485      >              as2n1, an1nf1, as2n3, an3nf1,
 486      >              an1n9, listar(6), af1f6, an3n11,
 487      >              as5n9, an9f6, as5n11, an11f6,
 488      >              lehexa, jaux, indhex )
 489 c
 490 c====
 491 c 5. la fin
 492 c====
 493 c
 494       if ( codret.ne.0 ) then
 495 c
 496 #include "envex2.h"
 497 c
 498       write (ulsort,texte(langue,1)) 'Sortie', nompro
 499       write (ulsort,texte(langue,2)) codret
 500 c
 501       endif
 502 c
 503 #ifdef _DEBUG_HOMARD_
 504       write (ulsort,texte(langue,1)) 'Sortie', nompro
 505       call dmflsh (iaux)
 506 #endif
 507 c
 508       end