src/tool/Creation_Maillage/cmch46.F

   1       subroutine cmch46 ( 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 46
  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 = 'CMCH46' )
 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 = 6
 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) = 4
 185       tabaux(2) = 5
 186       tabaux(3) = 3
 187       tabaux(4) = 2
 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(3)
 200       somm(3) = listso(4)
 201       somm(4) = listso(1)
 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( 3)
 211       arext2 = listar( 4)
 212       arext3 = listar( 2)
 213       arext4 = listar( 1)
 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 : NF6
 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) : S3
 227 c     somm(3) : S4
 228 c     somm(4) : S1
 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) : F6S5
 232 c     quabas(2) : F6S8
 233 c     quabas(3) : F6S7
 234 c     quabas(4) : F6S6
 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) : AN11NF6
 239 c     arefad(2) : AN12NF6
 240 c     arefad(3) : AN10NF6
 241 c     arefad(4) : AN9NF6
 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) : FF4
 260 c     trifad(1,1) : FF4 + 1/2
 261 c     trifad(1,2) : FF4 + 2/1
 262 c     areqtr(1,1) : AS2N11
 263 c     areqtr(1,2) : AS3N11
 264 c
 265 c     trifad(2,0) : FF5
 266 c     trifad(2,1) : FF5 + 1/2
 267 c     trifad(2,2) : FF5 + 2/1
 268 c     areqtr(2,1) : AS3N12
 269 c     areqtr(2,2) : AS4N12
 270 c
 271 c     trifad(3,0) : FF3
 272 c     trifad(3,1) : FF3 + 1/2
 273 c     trifad(3,2) : FF3 + 2/1
 274 c     areqtr(3,1) : AS4N10
 275 c     areqtr(3,2) : AS1N10
 276 c
 277 c     trifad(4,0) : FF2
 278 c     trifad(4,1) : FF2 + 1/2
 279 c     trifad(4,2) : FF2 + 2/1
 280 c     areqtr(4,1) : AS1N9
 281 c     areqtr(4,2) : AS2N9
 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) : AS2NF6
 286 c     areint(2) : AS3NF6
 287 c     areint(3) : AS4NF6
 288 c     areint(4) : AS1NF6
 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) : P6A1S2
 294 c     triint(1,2) : P6A1S3
 295 c     triint(2,1) : P6A2S3
 296 c     triint(2,2) : P6A2S4
 297 c     triint(3,1) : P6A1S4
 298 c     triint(3,2) : P6A1S1
 299 c     triint(4,1) : P6A2S1
 300 c     triint(4,2) : P6A2S2
 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) : PA3F6
 306 c     trigpy(2) : PA4F6
 307 c     trigpy(3) : PA2F6
 308 c     trigpy(4) : PA1F6
 309 c====
 310 c
 311 #ifdef _DEBUG_HOMARD_
 312       write (ulsort,texte(langue,3)) 'CMCH40_46', 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_46', 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(4),      3,
 347      >              trigpy(3),      3,
 348      >              trigpy(2),      3,
 349      >              trigpy(1),      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