src/tool/Creation_Maillage/cmch68.F

   1       subroutine cmch68 ( lehexa, listar, listso,
   2      >                    indare, indtri, indpyr,
   3      >                    indptp,
   4      >                    hetare, somare,
   5      >                    filare, merare, famare,
   6      >                    hettri, aretri,
   7      >                    filtri, pertri, famtri,
   8      >                    nivtri,
   9      >                    filqua,
  10      >                    hetpyr, facpyr, cofapy,
  11      >                    filpyr, perpyr, fampyr,
  12      >                    quahex, coquhe,
  13      >                    famhex, cfahex,
  14      >                    ulsort, langue, codret )
  15 c ______________________________________________________________________
  16 c
  17 c                             H O M A R D
  18 c
  19 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  20 c
  21 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  22 c aupres des huissiers de justice Simart et Lavoir a Clamart
  23 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  24 c aupres des huissiers de justice
  25 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  26 c
  27 c    HOMARD est une marque deposee d'Electricite de France
  28 c
  29 c Copyright EDF 1996
  30 c Copyright EDF 1998
  31 c Copyright EDF 2002
  32 c Copyright EDF 2020
  33 c ______________________________________________________________________
  34 c
  35 c    Creation du Maillage - Conformite - decoupage des Hexaedres
  36 c    -           -          -                          -
  37 c                         - par 1 Arete - etat 68
  38 c                                              --
  39 c ______________________________________________________________________
  40 c .        .     .        .                                            .
  41 c .  nom   . e/s . taille .           description                      .
  42 c .____________________________________________________________________.
  43 c . lehexa . e   .   1    . hexaedre a decouper                        .
  44 c . listar . e   .   12   . liste des aretes de l'hexaedre a decouper  .
  45 c . listso . e   .    8   . liste des sommets de l'hexaedre a decouper .
  46 c . indare . es  .   1    . indice de la derniere arete creee          .
  47 c . indtri . es  .   1    . indice du dernier triangle cree            .
  48 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  49 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  50 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  51 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  52 c . filare . es  . nouvar . premiere fille des aretes                  .
  53 c . merare . es  . nouvar . mere des aretes                            .
  54 c . famare .     . nouvar . famille des aretes                         .
  55 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  56 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  57 c . filtri . es  . nouvtr . premier fils des triangles                 .
  58 c . pertri . es  . nouvtr . pere des triangles                         .
  59 c . famtri . es  . nouvtr . famille des triangles                      .
  60 c . nivtri . es  . nouvtr . niveau des triangles                       .
  61 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  62 c . hetpyr . e   . nouvpy . historique de l'etat des pyramides         .
  63 c . facpyr . e   .nouvyf*5. numeros des 5 faces des pyramides          .
  64 c . cofapy . e   .nouvyf*5. codes des faces des pyramides              .
  65 c . filpyr . e   . nouvpy . premier fils des pyramides                 .
  66 c . perpyr . e   . nouvpy . pere des pyramides                         .
  67 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  68 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  69 c . fampyr . e   . nouvpy . famille des pyramides                      .
  70 c . quahex . e   .nouvhf*6. numeros des 6 quadrangles des hexaedres    .
  71 c . coquhe . e   .nouvhf*6. codes des 6 quadrangles des hexaedres      .
  72 c . famhex . e   . nouvhe . famille des hexaedres                      .
  73 c . cfahex .     . nctfhe. codes des familles des hexaedres            .
  74 c .        .     . nbfhex .   1 : famille MED                          .
  75 c .        .     .        .   2 : type d'hexaedres                     .
  76 c .        .     .        .   3 : famille des tetraedres de conformite .
  77 c .        .     .        .   4 : famille des pyramides de conformite  .
  78 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  79 c . langue . e   .    1   . langue des messages                        .
  80 c .        .     .        . 1 : francais, 2 : anglais                  .
  81 c . codret . es  .    1   . code de retour des modules                 .
  82 c .        .     .        . 0 : pas de probleme                        .
  83 c .        .     .        . 1 : aucune arete ne correspond             .
  84 c ______________________________________________________________________
  85 c
  86 c====
  87 c 0. declarations et dimensionnement
  88 c====
  89 c
  90 c 0.1. ==> generalites
  91 c
  92       implicit none
  93       save
  94 c
  95       character*6 nompro
  96       parameter ( nompro = 'CMCH68' )
  97 c
  98 #include "nblang.h"
  99 c
 100 c 0.2. ==> communs
 101 c
 102 #include "envex1.h"
 103 c
 104 #include "dicfen.h"
 105 #include "nbfami.h"
 106 #include "nouvnb.h"
 107 #include "cofpfh.h"
 108 c
 109 c 0.3. ==> arguments
 110 c
 111       integer lehexa
 112       integer listar(12), listso(8)
 113       integer indare, indtri, indpyr
 114       integer indptp
 115       integer hetare(nouvar), somare(2,nouvar)
 116       integer filare(nouvar), merare(nouvar), famare(nouvar)
 117       integer hettri(nouvtr), aretri(nouvtr,3)
 118       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 119       integer nivtri(nouvtr)
 120       integer filqua(nouvqu)
 121       integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
 122       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 123       integer quahex(nouvhf,6), coquhe(nouvhf,6)
 124       integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
 125 c
 126       integer ulsort, langue, codret
 127 c
 128 c 0.4. ==> variables locales
 129 c
 130       integer iaux, jaux
 131       integer nlarco, nuarco
 132       integer noemil, somm(2)
 133       integer areint(2)
 134       integer areqtr(2,2)
 135       integer triint(5)
 136       integer f1, f2, f3, f4, f5, f6
 137       integer cf1, cf2, cf3, cf4, cf5, cf6
 138       integer trifad(2,0:2), cotrvo(2,0:2)
 139       integer niveau
 140       integer laface, coface
 141 c
 142       integer nbmess
 143       parameter ( nbmess = 10 )
 144       character*80 texte(nblang,nbmess)
 145 c
 146 c 0.5. ==> initialisations
 147 c ______________________________________________________________________
 148 c
 149 c====
 150 c 1. initialisations
 151 c====
 152 c
 153 c 1.1. ==> messages
 154 c
 155 #include "impr01.h"
 156 c
 157 #ifdef _DEBUG_HOMARD_
 158       write (ulsort,texte(langue,1)) 'Entree', nompro
 159       call dmflsh (iaux)
 160 #endif
 161 c
 162 #ifdef _DEBUG_HOMARD_
 163  1789 format(5(a,i5,', '))
 164 #endif
 165 c
 166       codret = 0
 167 c
 168 c 1.2. ==> grandeurs independantes du cas traite (phase 1)
 169 c          les faces de l'hexaedre et leurs codes
 170 c
 171       f1 = quahex(lehexa,1)
 172       f2 = quahex(lehexa,2)
 173       f3 = quahex(lehexa,3)
 174       f4 = quahex(lehexa,4)
 175       f5 = quahex(lehexa,5)
 176       f6 = quahex(lehexa,6)
 177       cf1 = coquhe(lehexa,1)
 178       cf2 = coquhe(lehexa,2)
 179       cf3 = coquhe(lehexa,3)
 180       cf4 = coquhe(lehexa,4)
 181       cf5 = coquhe(lehexa,5)
 182       cf6 = coquhe(lehexa,6)
 183 c
 184 c 1.3. ==> grandeurs dependant du cas traite
 185 c     nlarco = numero local de l'arete coupee
 186       nlarco = 8
 187 c
 188 c     nuarco = numero global de l'arete coupee
 189       nuarco = listar(nlarco)
 190 c
 191 c     noemil = noeud milieu de l'arete coupee
 192       noemil = somare(2,filare(nuarco))
 193 c
 194 c     somm(1) = sommet a joindre au milieu de l'arete coupee pour
 195 c               definir la 1ere arete interne
 196       somm(1) = listso(1)
 197 c     somm(2) = sommet a joindre au milieu de l'arete coupee pour
 198 c               definir la 2nde arete interne
 199       somm(2) = listso(6)
 200 #ifdef _DEBUG_HOMARD_
 201       write(ulsort,2000) 'listso', listso
 202       write(ulsort,2000) 'nuarco', nuarco
 203       write(ulsort,2000) 'noemil', noemil
 204       write(ulsort,2001) 'somm(1)', somm(1),'somm(2)', somm(2)
 205  2000 format(a,10i10)
 206  2001 format(a,i10,', ',a,i10)
 207 #endif
 208 c
 209 c 2.2.6. ==> Triangles et aretes tracees sur les faces coupees en 3
 210 c            L'arete coupee s'appuie sur deux faces de l'hexaedre.
 211 c            trifad(1,*)  se rapporte a celle de plus petit numero local
 212 c            trifad(2,*)  se rapporte a celle de plus grand numero local
 213 c     trifad(p,0) : triangle central de ce decoupage
 214 c     trifad(p,1) : triangle contenant le sommet de l'arete coupee qui a
 215 c                   le plus petit numero local
 216 c     trifad(p,2) : triangle contenant le sommet de l'arete coupee qui a
 217 c                   le plus petit numero local
 218 c     cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la
 219 c                       description de la pyramide
 220 c     areqtr(p,1) : arete interne au quadrangle de bord et bordant le
 221 c                   triangle trifad(p,1)
 222 c     areqtr(p,2) : arete interne au quadrangle de bord et bordant le
 223 c                   triangle trifad(p,2)
 224 c
 225 c     trifad(1,0) = triangle central de la face 1 : FF4
 226 c     trifad(1,1) = triangle de la face 1 du cote de S3 : FF4 + 2/1
 227 c     trifad(1,2) = triangle de la face 1 du cote de S8 : FF4 + 1/2
 228 c     areqtr(1,1) : AS2N8
 229 c     areqtr(1,2) : AS5N8
 230       laface = f4
 231       coface = cf4
 232       trifad(1,0) = -filqua(laface)
 233       if ( coface.lt.5 ) then
 234         cotrvo(1,0) = 2
 235         trifad(1,1) = trifad(1,0) + 2
 236         cotrvo(1,1) = 3
 237         trifad(1,2) = trifad(1,0) + 1
 238         cotrvo(1,2) = 2
 239         areqtr(1,1) = aretri(trifad(1,0),3)
 240         areqtr(1,2) = aretri(trifad(1,0),1)
 241       else
 242         cotrvo(1,0) = 4
 243         trifad(1,1) = trifad(1,0) + 1
 244         cotrvo(1,1) = 5
 245         trifad(1,2) = trifad(1,0) + 2
 246         cotrvo(1,2) = 6
 247         areqtr(1,1) = aretri(trifad(1,0),1)
 248         areqtr(1,2) = aretri(trifad(1,0),3)
 249       endif
 250 #ifdef _DEBUG_HOMARD_
 251       write(ulsort,1789) 'laface = ', laface,', coface = ', coface
 252       write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0),
 253      >                   'trifad(1,1) = ', trifad(1,1),
 254      >                   'trifad(1,2) = ', trifad(1,2)
 255       write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0),
 256      >                   'cotrvo(1,1) = ', cotrvo(1,1),
 257      >                   'cotrvo(1,2) = ', cotrvo(1,2)
 258 #endif
 259 c
 260 c     trifad(2,0) = triangle central de la face 2 : FF5
 261 c     trifad(2,1) = triangle de la face 2 du cote de S3 : FF5 + 1/2
 262 c     trifad(2,2) = triangle de la face 2 du cote de S8 : FF5 + 2/1
 263 c     areqtr(2,1) : AS4N8
 264 c     areqtr(2,2) : AS7N8
 265       laface = f5
 266       coface = cf5
 267       trifad(2,0) = -filqua(laface)
 268       if ( coface.lt.5 ) then
 269         cotrvo(2,0) = 1
 270         trifad(2,1) = trifad(2,0) + 1
 271         cotrvo(2,1) = 2
 272         trifad(2,2) = trifad(2,0) + 2
 273         cotrvo(2,2) = 1
 274         areqtr(2,1) = aretri(trifad(2,0),1)
 275         areqtr(2,2) = aretri(trifad(2,0),3)
 276       else
 277         cotrvo(2,0) = 5
 278         trifad(2,1) = trifad(2,0) + 2
 279         cotrvo(2,1) = 6
 280         trifad(2,2) = trifad(2,0) + 1
 281         cotrvo(2,2) = 4
 282         areqtr(2,1) = aretri(trifad(2,0),3)
 283         areqtr(2,2) = aretri(trifad(2,0),1)
 284       endif
 285 #ifdef _DEBUG_HOMARD_
 286       write(ulsort,1789) 'laface = ', laface,', coface = ', coface
 287       write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0),
 288      >                   'trifad(2,1) = ', trifad(2,1),
 289      >                   'trifad(2,2) = ', trifad(2,2)
 290       write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0),
 291      >                   'cotrvo(2,1) = ', cotrvo(2,1),
 292      >                   'cotrvo(2,2) = ', cotrvo(2,2)
 293 #endif
 294 c
 295 c 1.4. ==> grandeurs independantes du cas traite (phase 2)
 296 c
 297 c     niveau = niveau des triangles des conformites des faces
 298       niveau = nivtri(trifad(1,0))
 299 #ifdef _DEBUG_HOMARD_
 300       write(ulsort,1400) niveau
 301  1400 format('niveau =',i3)
 302 #endif
 303 c
 304 c====
 305 c 2. Creation des deux aretes internes
 306 c    noemil : N8
 307 c    somm(1) : S1
 308 c    somm(2) : S6
 309 c    areint(1) : AS1N8
 310 c    areint(2) : AS6N8
 311 c====
 312 c
 313       if ( codret.eq.0 ) then
 314 c
 315       do 21 , iaux = 1 , 2
 316 c
 317         indare = indare + 1
 318         areint(iaux) = indare
 319 c
 320         somare(1,areint(iaux)) = min ( noemil , somm(iaux) )
 321         somare(2,areint(iaux)) = max ( noemil , somm(iaux) )
 322 c
 323         famare(areint(iaux)) = 1
 324         hetare(areint(iaux)) = 50
 325         merare(areint(iaux)) = 0
 326         filare(areint(iaux)) = 0
 327 c
 328    21 continue
 329 c
 330       endif
 331 c
 332 c====
 333 c 3. Creation des cinq triangles internes
 334 c    areqtr(1,1) : AS2N8
 335 c    areqtr(1,2) : AS5N8
 336 c    areqtr(2,1) : AS4N8
 337 c    areqtr(2,2) : AS7N8
 338 c    areint(1) : AS1N8
 339 c    areint(2) : AS6N8
 340 c    triint(1) : le triangle contenant l'arete areqtr(1,1)
 341 c    triint(3) : le triangle contenant l'arete areqtr(1,2)
 342 c    triint(2) : le triangle contenant l'arete areqtr(2,1)
 343 c    triint(4) : le triangle contenant l'arete areqtr(2,2)
 344 c    triint(5) : le triangle qui s'appuie sur l'arete opposee a l'arete
 345 c                coupee ; il ne touche donc pas les faces coupees
 346 c    triint(1) : FN8A1
 347 c    triint(2) : FN8A9
 348 c    triint(3) : FN8A2
 349 c    triint(4) : FN8A10
 350 c    triint(5) : FN8A5
 351 c     par convention, le niveau est le meme que les triangles fils
 352 c     sur l'exterieur
 353 c====
 354 c
 355       iaux = 1
 356 c
 357 #ifdef _DEBUG_HOMARD_
 358       write (ulsort,texte(langue,3)) 'CMCTRI_68', nompro
 359       write (ulsort,3000) indtri+1, indtri+5
 360  3000 format('.. triangles de',i10,' a',i10)
 361 #endif
 362       triint(1) = indtri + 1
 363       call cmctri ( aretri, famtri, hettri,
 364      >              filtri, pertri, nivtri,
 365      >              triint(1), listar( 1), areint(1), areqtr(1,1),
 366      >              iaux, niveau )
 367 c
 368       triint(2) = indtri + 2
 369       call cmctri ( aretri, famtri, hettri,
 370      >              filtri, pertri, nivtri,
 371      >              triint(2), listar( 9), areqtr(1,2), areint(2),
 372      >              iaux, niveau )
 373 c
 374       triint(3) = indtri + 3
 375       call cmctri ( aretri, famtri, hettri,
 376      >              filtri, pertri, nivtri,
 377      >              triint(3), listar( 2), areint(1), areqtr(2,1),
 378      >              iaux, niveau )
 379 c
 380       triint(4) = indtri + 4
 381       call cmctri ( aretri, famtri, hettri,
 382      >              filtri, pertri, nivtri,
 383      >              triint(4), listar(10), areint(2), areqtr(2,2),
 384      >              iaux, niveau )
 385 c
 386       triint(5) = indtri + 5
 387       call cmctri ( aretri, famtri, hettri,
 388      >              filtri, pertri, nivtri,
 389      >              triint(5), listar( 5), areint(1), areint(2),
 390      >              iaux, niveau )
 391 c
 392       indtri = triint(5)
 393 c
 394 c====
 395 c 4. Creation des quatre pyramides
 396 c    Elles arrivent dans l'ordre de numerotation locale de leur
 397 c    quadrangle dans l'hexaedre
 398 c    trifad(1,0) : FF4
 399 c    trifad(1,1) : FF4 + 2/1
 400 c    trifad(1,2) : FF4 + 1/2
 401 c    trifad(2,0) : FF5
 402 c    trifad(2,1) : FF5 + 1/2
 403 c    trifad(2,2) : FF5 + 2/1
 404 c    triint(1) : FN8A1
 405 c    triint(2) : FN8A9
 406 c    triint(3) : FN8A2
 407 c    triint(4) : FN8A10
 408 c    triint(5) : FN8A5
 409 c====
 410 c
 411       jaux = cfahex(cofpfh,famhex(lehexa))
 412       iaux = -indptp
 413 c
 414 #ifdef _DEBUG_HOMARD_
 415       write (ulsort,texte(langue,3)) 'CMCPYR_68', nompro
 416       write (ulsort,4000) indpyr+1, indpyr+4
 417  4000 format('.. pyramides de',i10,' a',i10)
 418 #endif
 419       indpyr = indpyr + 1
 420       call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
 421      >              triint(1),        5,
 422      >               triint(3),        3,
 423      >               trifad(2,1), cotrvo(2,1),
 424      >               trifad(1,1), cotrvo(1,1),
 425      >                  f1,   cf1,
 426      >              iaux,  jaux,   indpyr )
 427 c
 428       indpyr = indpyr + 1
 429       call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
 430      >              triint(1),       3,
 431      >               trifad(1,0), cotrvo(1,0),
 432      >               triint(2),       3,
 433      >               triint(5),       6,
 434      >                  f2,  cf2,
 435      >              iaux,  jaux,   indpyr )
 436 c
 437       indpyr = indpyr + 1
 438       call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
 439      >              triint(3),       5,
 440      >                triint(5),      3,
 441      >                triint(4),     3,
 442      >                trifad(2,0), cotrvo(2,0),
 443      >                  f3,   cf3,
 444      >              iaux,  jaux,   indpyr )
 445 c
 446       indpyr = indpyr + 1
 447       call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
 448      >              triint(2),       5,
 449      >              trifad(1,2), cotrvo(1,2),
 450      >              trifad(2,2), cotrvo(2,2),
 451      >                triint(4),       6,
 452      >                  f6,    cf6,
 453      >              iaux,  jaux,   indpyr )
 454 c
 455 c====
 456 c 5. la fin
 457 c====
 458 c
 459       if ( codret.ne.0 ) then
 460 c
 461 #include "envex2.h"
 462 c
 463       write (ulsort,texte(langue,1)) 'Sortie', nompro
 464       write (ulsort,texte(langue,2)) codret
 465       write (ulsort,texte(langue,4))
 466 c
 467       endif
 468 c
 469 #ifdef _DEBUG_HOMARD_
 470       write (ulsort,texte(langue,1)) 'Sortie', nompro
 471       call dmflsh (iaux)
 472 #endif
 473 c
 474       end