src/tool/Creation_Maillage/cmch41.F

   1       subroutine cmch41 ( 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 41
  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 = 'CMCH41' )
 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 = 1
 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) = 3
 185       tabaux(2) = 5
 186       tabaux(3) = 4
 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(6)
 199       somm(2) = listso(7)
 200       somm(3) = listso(8)
 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(10)
 211       arext2 = listar(12)
 212       arext3 = listar(11)
 213       arext4 = listar( 9)
 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 : NF1
 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) : S6
 226 c     somm(2) : S7
 227 c     somm(3) : S8
 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) : F1S1
 232 c     quabas(2) : F1S4
 233 c     quabas(3) : F1S3
 234 c     quabas(4) : F1S2
 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) : AN2NF1
 239 c     arefad(2) : AN4NF1
 240 c     arefad(3) : AN3NF1
 241 c     arefad(4) : AN1NF1
 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) : FF3
 260 c     trifad(1,1) : FF3 + 1/2
 261 c     trifad(1,2) : FF3 + 2/1
 262 c     areqtr(1,1) : AS6N2
 263 c     areqtr(1,2) : AS7N2
 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) : AS7N4
 269 c     areqtr(2,2) : AS8N4
 270 c
 271 c     trifad(3,0) : FF4
 272 c     trifad(3,1) : FF4 + 1/2
 273 c     trifad(3,2) : FF4 + 2/1
 274 c     areqtr(3,1) : AS8N3
 275 c     areqtr(3,2) : AS5N3
 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) : AS5N1
 281 c     areqtr(4,2) : AS6N1
 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) : AS6N1
 286 c     areint(2) : AS7N1
 287 c     areint(3) : AS8N1
 288 c     areint(4) : AS5N1
 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) : P1A1S6
 294 c     triint(1,2) : P1A1S7
 295 c     triint(2,1) : P1A2S7
 296 c     triint(2,2) : P1A2S8
 297 c     triint(3,1) : P1A1S8
 298 c     triint(3,2) : P1A1S5
 299 c     triint(4,1) : P1A2S5
 300 c     triint(4,2) : P1A2S6
 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) : PA10F1
 306 c     trigpy(2) : PA12F1
 307 c     trigpy(3) : PA11F1
 308 c     trigpy(4) : PA9F1
 309 c====
 310 c
 311 #ifdef _DEBUG_HOMARD_
 312       write (ulsort,texte(langue,3)) 'CMCH40_41', 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_41', 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