src/tool/Creation_Maillage/cmch45.F

   1       subroutine cmch45 ( lehexa, listar, listso,
   2      >                    indare, indtri, indtet, indpyr,
   3      >                    indptp,
   4      >                    hetare, somare,
   5      >                    filare, merare, famare,
   6      >                    hettri, aretri,
   7      >                    filtri, pertri, famtri,
   8      >                    nivtri,
   9      >                    arequa, filqua,
  10      >                    hettet, tritet, cotrte,
  11      >                    filtet, pertet, famtet,
  12      >                    hetpyr, facpyr, cofapy,
  13      >                    filpyr, perpyr, fampyr,
  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 1 Face - etat 45
  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 . listar . e   .   12   . liste des aretes de l'hexaedre a decouper  .
  47 c . listso . e   .    8   . liste des sommets de l'hexaedre a decouper .
  48 c . indare . es  .   1    . indice de la derniere arete creee          .
  49 c . indtri . es  .   1    . indice du dernier triangle cree            .
  50 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  51 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  52 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  53 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  54 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  55 c . filare . es  . nouvar . premiere fille des aretes                  .
  56 c . merare . es  . nouvar . mere des aretes                            .
  57 c . famare .     . nouvar . famille des aretes                         .
  58 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  59 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  60 c . filtri . es  . nouvtr . premier fils des triangles                 .
  61 c . pertri . es  . nouvtr . pere des triangles                         .
  62 c . famtri . es  . nouvtr . famille des triangles                      .
  63 c . nivtri . es  . nouvtr . niveau des triangles                       .
  64 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  65 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  66 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  67 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  68 c . cotrte . e   .nouvtf*4. code des 4 triangles des tetraedres        .
  69 c . filtet . es  . nouvte . premier fils des tetraedres                .
  70 c . pertet . es  . nouvte . pere des tetraedres                        .
  71 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  72 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  73 c . famtet . es  . nouvte . famille des tetraedres                     .
  74 c . hetpyr . e   . nouvpy . historique de l'etat des pyramides         .
  75 c . facpyr . e   .nouvyf*5. numeros des 5 faces des pyramides          .
  76 c . cofapy . e   .nouvyf*5. codes des faces des pyramides              .
  77 c . filpyr . e   . nouvpy . premier fils des pyramides                 .
  78 c . perpyr . e   . 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 . e   . nouvpy . famille des pyramides                      .
  82 c . quahex . e   .nouvhf*6. numeros des 6 quadrangles des hexaedres    .
  83 c . coquhe . e   .nouvhf*6. codes des 6 quadrangles des hexaedres      .
  84 c . famhex . e   . nouvhe . famille des hexaedres                      .
  85 c . cfahex .     . nctfhe. codes des familles des hexaedres            .
  86 c .        .     . nbfhex .   1 : famille MED                          .
  87 c .        .     .        .   2 : type d'hexaedres                     .
  88 c .        .     .        .   3 : famille des tetraedres de conformite .
  89 c .        .     .        .   4 : famille des pyramides de conformite  .
  90 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  91 c . langue . e   .    1   . langue des messages                        .
  92 c .        .     .        . 1 : francais, 2 : anglais                  .
  93 c . codret . es  .    1   . code de retour des modules                 .
  94 c .        .     .        . 0 : pas de probleme                        .
  95 c .        .     .        . 1 : aucune face ne correspond              .
  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       character*6 nompro
 108       parameter ( nompro = 'CMCH45' )
 109 c
 110 #include "nblang.h"
 111 c
 112 c 0.2. ==> communs
 113 c
 114 #include "envex1.h"
 115 c
 116 #include "dicfen.h"
 117 #include "nbfami.h"
 118 #include "nouvnb.h"
 119 c
 120 c 0.3. ==> arguments
 121 c
 122       integer lehexa
 123       integer listar(12), listso(8)
 124       integer indare, indtri, indtet, indpyr
 125       integer indptp
 126       integer hetare(nouvar), somare(2,nouvar)
 127       integer filare(nouvar), merare(nouvar), famare(nouvar)
 128       integer hettri(nouvtr), aretri(nouvtr,3)
 129       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 130       integer nivtri(nouvtr)
 131       integer arequa(nouvqu,4), filqua(nouvqu)
 132       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 133       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 134       integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
 135       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 136       integer quahex(nouvhf,6), coquhe(nouvhf,6)
 137       integer famhex(nouvhe), cfahex(nctfhe,nbfhex)
 138 c
 139       integer ulsort, langue, codret
 140 c
 141 c 0.4. ==> variables locales
 142 c
 143       integer iaux, jaux
 144       integer tabaux(4)
 145       integer somm(4)
 146       integer arext1, arext2, arext3, arext4
 147       integer trigpy(4)
 148       integer facnde, cofnde
 149 c
 150       integer nbmess
 151       parameter ( nbmess = 10 )
 152       character*80 texte(nblang,nbmess)
 153 c
 154 c 0.5. ==> initialisations
 155 c ______________________________________________________________________
 156 c
 157 c====
 158 c 1. messages
 159 c====
 160 c
 161 #include "impr01.h"
 162 c
 163 #ifdef _DEBUG_HOMARD_
 164       write (ulsort,texte(langue,1)) 'Entree', nompro
 165       call dmflsh (iaux)
 166 #endif
 167 c
 168 #ifdef _DEBUG_HOMARD_
 169  1789 format(5(a,i5,', '))
 170 #endif
 171 c
 172       codret = 0
 173 c
 174 c====
 175 c 2. initialisations
 176 c====
 177 c 2.1. ==> le numero local de la face coupee en 4
 178 c
 179       iaux = 5
 180 c
 181 c 2.2. ==> les numeros locaux des faces coupees en 3, dans l'ordre
 182 c          des pyramides p/p+1
 183 c
 184       tabaux(1) = 1
 185       tabaux(2) = 3
 186       tabaux(3) = 6
 187       tabaux(4) = 4
 188 #ifdef _DEBUG_HOMARD_
 189       write(ulsort,1789) 'tabaux(1) = ', tabaux(1),
 190      >                   'tabaux(2) = ', tabaux(2),
 191      >                   'tabaux(3) = ', tabaux(3),
 192      >                   'tabaux(4) = ', tabaux(4)
 193 #endif
 194 c
 195 c 2.3. ==> Sommets de la face opposee a la face coupee
 196 c          somm(p) est la pointe de la pyramide fille numero p
 197 c
 198       somm(1) = listso(2)
 199       somm(2) = listso(1)
 200       somm(3) = listso(6)
 201       somm(4) = listso(5)
 202 #ifdef _DEBUG_HOMARD_
 203       write(ulsort,1789) 'somm(1) = ', somm(1),'somm(2) = ', somm(2),
 204      >                   'somm(3) = ', somm(3),'somm(4) = ', somm(4)
 205 #endif
 206 c
 207 c 2.4. ==> Aretes de la face opposee a la face coupee
 208 c          arextp relie les pyramides p et p+1
 209 c
 210       arext1 = listar( 1)
 211       arext2 = listar( 5)
 212       arext3 = listar( 9)
 213       arext4 = listar( 6)
 214 #ifdef _DEBUG_HOMARD_
 215       write(ulsort,1789) 'arext1 = ', arext1, 'arext2 = ', arext2,
 216      >                   'arext3 = ', arext3, 'arext4 = ', arext4
 217 #endif
 218 c
 219 c====
 220 c 3. Creation
 221 c          Noeud central de la face coupee en 4
 222 c     noefac : NF5
 223 c          Sommets de la face opposee a la face coupee
 224 c          somm(p) est la pointe de la pyramide fille numero p
 225 c     somm(1) : S2
 226 c     somm(2) : S1
 227 c     somm(3) : S6
 228 c     somm(4) : S5
 229 c          Quadrangles fils de la face coupee en 4
 230 c          quabas(p) est la base de la pyramide fille numero p
 231 c     quabas(1) : F5S3
 232 c     quabas(2) : F5S4
 233 c     quabas(3) : F5S7
 234 c     quabas(4) : F5S8
 235 c          Aretes tracees sur la face coupee en 4
 236 c          arefad(p) est l'arete commune aux pyramides filles
 237 c          numero p et p+1
 238 c     arefad(1) : AN4NF5
 239 c     arefad(2) : AN7NF5
 240 c     arefad(3) : AN12NF5
 241 c     arefad(4) : AN8NF5
 242 c          Triangles et aretes tracees sur les faces coupees en 3
 243 c          Chaque quadrangle de bord qui est decoupe en 3 triangles
 244 c          borde deux pyramides consecutives : p et p+1
 245 c     trifad(p,0) : triangle central de ce decoupage
 246 c     trifad(p,1) : triangle bordant la pyramide p
 247 c     trifad(p,2) : triangle bordant la pyramide p+1
 248 c     cotrvo(p,0) : futur code du triangle trifad(p,0) dans la
 249 c                   description du tetraedre p
 250 c     cotrvo(p,1) : futur code du triangle trifad(p,1) dans la
 251 c                   description de la pyramide p
 252 c     cotrvo(p,2) : futur code du triangle trifad(p,2) dans la
 253 c                   description de la pyramide p+1
 254 c     areqtr(p,1) : arete interne au quadrangle de bord et bordant le
 255 c                   triangle trifad(p,1)
 256 c     areqtr(p,2) : arete interne au quadrangle de bord et bordant le
 257 c                   triangle trifad(p,2)
 258 c
 259 c     trifad(1,0) : FF1
 260 c     trifad(1,1) : FF1 + 1/2
 261 c     trifad(1,2) : FF1 + 2/1
 262 c     areqtr(1,1) : AS3N4
 263 c     areqtr(1,2) : AS4N4
 264 c
 265 c     trifad(2,0) : FF3
 266 c     trifad(2,1) : FF3 + 1/2
 267 c     trifad(2,2) : FF3 + 2/1
 268 c     areqtr(2,1) : AS4N7
 269 c     areqtr(2,2) : AS7N7
 270 c
 271 c     trifad(3,0) : FF6
 272 c     trifad(3,1) : FF6 + 1/2
 273 c     trifad(3,2) : FF6 + 2/1
 274 c     areqtr(3,1) : AS7N12
 275 c     areqtr(3,2) : AS8N12
 276 c
 277 c     trifad(4,0) : FF4
 278 c     trifad(4,1) : FF4 + 1/2
 279 c     trifad(4,2) : FF4 + 2/1
 280 c     areqtr(4,1) : AS8N8
 281 c     areqtr(4,2) : AS3N8
 282 c
 283 c    areint(p) relie le sommet somm(p) (de la pyramide fille p)
 284 c    au centre de la face coupee
 285 c     areint(1) : AS2NF5
 286 c     areint(2) : AS1NF5
 287 c     areint(3) : AS6NF5
 288 c     areint(4) : AS5NF5
 289 c
 290 c        Triangles s'appuyant sur la face decoupee
 291 c     triint(p,1) : triangle contenant arefad(p) et de la pyramide p
 292 c     triint(p,2) : triangle contenant arefad(p) et de la pyramide p+1
 293 c     triint(1,1) : P2A5S4
 294 c     triint(1,2) : P2A5S3
 295 c     triint(2,1) : P2A1S3
 296 c     triint(2,2) : P2A1S8
 297 c     triint(3,1) : P2A5S8
 298 c     triint(3,2) : P2A5S7
 299 c     triint(4,1) : P2A1S7
 300 c     triint(4,2) : P2A1S4
 301 c
 302 c     Triangles s'appuyant sur les aretes de la face non decoupee
 303 c          Ce sont ceux qui bordent la grande pyramide
 304 c     trigpy(t) : triangle appuyant sur le tetraedre t
 305 c     trigpy(1) : PA1F5
 306 c     trigpy(2) : PA5F5
 307 c     trigpy(3) : PA9F5
 308 c     trigpy(4) : PA6F5
 309 c====
 310 c
 311 #ifdef _DEBUG_HOMARD_
 312       write (ulsort,texte(langue,3)) 'CMCH40_45', nompro
 313 #endif
 314       call cmch40 ( lehexa, iaux, tabaux,
 315      >              somm, arext1, arext2, arext3, arext4,
 316      >              indare, indtri, indtet, indpyr, indptp,
 317      >              hetare, somare,
 318      >              filare, merare, famare,
 319      >              hettri, aretri,
 320      >              filtri, pertri, famtri,
 321      >              nivtri,
 322      >              arequa, filqua,
 323      >              hettet, tritet, cotrte,
 324      >              filtet, pertet, famtet,
 325      >              hetpyr, facpyr, cofapy,
 326      >              filpyr, perpyr, fampyr,
 327      >              quahex, coquhe,
 328      >              famhex, cfahex,
 329      >              trigpy, facnde, cofnde,
 330      >              ulsort, langue, codret )
 331 c
 332 c====
 333 c 4. Pyramide s'appuyant sur la face non decoupee,
 334 c          dite la 'grosse pyramide'
 335 c====
 336 c
 337       if ( codret.eq.0 ) then
 338 c
 339 #ifdef _DEBUG_HOMARD_
 340       write (ulsort,texte(langue,3)) 'CMCPYR_45', nompro
 341 #endif
 342       iaux = fampyr(indpyr)
 343       jaux = -indptp
 344       indpyr = indpyr + 1
 345       call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
 346      >              trigpy(1),      3,
 347      >              trigpy(4),      3,
 348      >              trigpy(3),      3,
 349      >              trigpy(2),      2,
 350      >                 facnde, cofnde,
 351      >              jaux,   iaux, indpyr )
 352 c
 353       endif
 354 c
 355 c====
 356 c 5. la fin
 357 c====
 358 c
 359       if ( codret.ne.0 ) then
 360 c
 361 #include "envex2.h"
 362 c
 363       write (ulsort,texte(langue,1)) 'Sortie', nompro
 364       write (ulsort,texte(langue,2)) codret
 365 c
 366       endif
 367 c
 368 #ifdef _DEBUG_HOMARD_
 369       write (ulsort,texte(langue,1)) 'Sortie', nompro
 370       call dmflsh (iaux)
 371 #endif
 372 c
 373       end