src/tool/Creation_Maillage/cmcp05.F

   1       subroutine cmcp05 ( lepent, 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      >                    filqua,
  10      >                    hettet, tritet, cotrte,
  11      >                    filtet, pertet, famtet,
  12      >                    hetpyr, facpyr, cofapy,
  13      >                    filpyr, perpyr, fampyr,
  14      >                    facpen, cofape,
  15      >                    fampen, cfapen,
  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 Pentaedres
  38 c    -           -          -                          -
  39 c                         - etat 05 - par l'arete de triangle 5
  40 c                                --
  41 c ______________________________________________________________________
  42 c .        .     .        .                                            .
  43 c .  nom   . e/s . taille .           description                      .
  44 c .____________________________________________________________________.
  45 c . lepent . e   .   1    . pentaedre a decouper                       .
  46 c . listar . e   .   9   . liste des aretes du pentaedre a decouper    .
  47 c . listso . e   .   6    . liste des sommets du pentaedre 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 . filqua . e   . nouvqu . premier fils des quadrangles               .
  65 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  66 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  67 c . cotrte . e   .nouvtf*4. code des 4 triangles des tetraedres        .
  68 c . filtet . es  . nouvte . premier fils des tetraedres                .
  69 c . pertet . es  . nouvte . pere des tetraedres                        .
  70 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  71 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  72 c . famtet . es  . nouvte . famille des tetraedres                     .
  73 c . hetpyr . es  . nouvpy . historique de l'etat des pyramides         .
  74 c . facpyr . es  .nouvyf*5. numeros des 5 faces des pyramides          .
  75 c . cofapy . es  .nouvyf*5. codes des faces des pyramides              .
  76 c . filpyr . es  . nouvpy . premier fils des pyramides                 .
  77 c . perpyr . es  . nouvpy . pere des pyramides                         .
  78 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  79 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  80 c . fampyr . es  . nouvpy . famille des pyramides                      .
  81 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  82 c . cofape . e   .nouvpf*5. codes des faces des pentaedres             .
  83 c . fampen . e   . nouvpe . famille des penaedres                      .
  84 c . cfapen . e   . nctfpe*. codes des familles des pentaedres          .
  85 c .        .     . nbfpen .   1 : famille MED                          .
  86 c .        .     .        .   2 : type de pentaedres                   .
  87 c .        .     .        .   3 : famille des tetraedres de conformite .
  88 c .        .     .        .   4 : famille des pyramides de conformite  .
  89 c .        .     .        .   3 : famille des tetraedres de conformite .
  90 c .        .     .        .   4 : famille des pyramides de conformite  .
  91 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  92 c . langue . e   .    1   . langue des messages                        .
  93 c .        .     .        . 1 : francais, 2 : anglais                  .
  94 c . codret . es  .    1   . code de retour des modules                 .
  95 c .        .     .        . 0 : pas de probleme                        .
  96 c .        .     .        . 1 : aucune face ne correspond              .
  97 c ______________________________________________________________________
  98 c
  99 c====
 100 c 0. declarations et dimensionnement
 101 c====
 102 c
 103 c 0.1. ==> generalites
 104 c
 105       implicit none
 106       save
 107 c
 108       character*6 nompro
 109       parameter ( nompro = 'CMCP05' )
 110 c
 111 #include "nblang.h"
 112 c
 113 c 0.2. ==> communs
 114 c
 115 #include "envex1.h"
 116 c
 117 #include "dicfen.h"
 118 #include "nbfami.h"
 119 #include "nouvnb.h"
 120 #include "ope001.h"
 121 #include "ope002.h"
 122 #include "i1i2i3.h"
 123 #include "coftfp.h"
 124 c
 125 c 0.3. ==> arguments
 126 c
 127       integer lepent
 128       integer listar(9), listso(6)
 129       integer indare, indtri, indtet, indpyr
 130       integer indptp
 131       integer hetare(nouvar), somare(2,nouvar)
 132       integer filare(nouvar), merare(nouvar), famare(nouvar)
 133       integer hettri(nouvtr), aretri(nouvtr,3)
 134       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 135       integer nivtri(nouvtr)
 136       integer filqua(nouvqu)
 137       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 138       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 139       integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
 140       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 141       integer facpen(nouvpf,5), cofape(nouvpf,5)
 142       integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
 143 c
 144       integer ulsort, langue, codret
 145 c
 146 c 0.4. ==> variables locales
 147 c
 148       integer iaux, jaux
 149       integer nupere, nufami
 150       integer f1, cf1
 151       integer f3, cf3
 152       integer f5, cf5
 153 #ifdef _DEBUG_HOMARD_
 154       integer f2, cf2
 155       integer f4, cf4
 156 #endif
 157       integer noemil, lesnoe(2), lesare(3)
 158       integer areint(1)
 159       integer triint(3)
 160       integer laface(2), coface(2)
 161       integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2)
 162       integer nulofa(2)
 163       integer ind001(2)
 164       integer niveau
 165 c
 166       integer nbmess
 167       parameter ( nbmess = 10 )
 168       character*80 texte(nblang,nbmess)
 169 c
 170 c 0.5. ==> initialisations
 171 c ______________________________________________________________________
 172 c
 173 c====
 174 c 1. messages
 175 c====
 176 c
 177 #include "impr01.h"
 178 c
 179 #ifdef _DEBUG_HOMARD_
 180       write (ulsort,texte(langue,1)) 'Entree', nompro
 181       call dmflsh (iaux)
 182 #endif
 183 c
 184 #include "impr03.h"
 185 #include "impr04.h"
 186 c
 187       codret = 0
 188 c
 189 c====
 190 c 2. initialisations
 191 c====
 192 #ifdef _DEBUG_HOMARD_
 193       write(ulsort,90002) 'listso', listso
 194 #endif
 195 c
 196 c 2.1. ==> grandeurs independantes du cas traite (phase 1)
 197 c          les faces du pentaedre et leurs codes
 198 c
 199       f1 = facpen(lepent,1)
 200       cf1 = cofape(lepent,1)
 201       f3 = facpen(lepent,3)
 202       cf3 = cofape(lepent,3)
 203       f5 = facpen(lepent,5)
 204       cf5 = cofape(lepent,5)
 205 #ifdef _DEBUG_HOMARD_
 206       f2 = facpen(lepent,2)
 207       cf2 = cofape(lepent,2)
 208       f4 = facpen(lepent,4)
 209       cf4 = cofape(lepent,4)
 210       write(ulsort,90002) 'f1', f1, cf1
 211       write(ulsort,90002) 'f2', f2, cf2
 212       write(ulsort,90002) 'f3', f3, cf3
 213       write(ulsort,90002) 'f4', f4, cf4
 214       write(ulsort,90002) 'f5', f5, cf5
 215       write (ulsort,90015) 'Triangle', f1,
 216      >                ', aretes', (aretri(f1,jaux),jaux=1,3)
 217 #endif
 218 c
 219 c 2.2. ==> grandeurs dependant du cas traite
 220 c     iaux = numero local de l'arete coupee
 221 c     jaux = numero global de l'arete coupee
 222 c     noemil = noeud milieu de l'arete coupee
 223 c
 224       iaux = 5
 225       jaux = listar(iaux)
 226       noemil = somare(2,filare(jaux))
 227 c
 228 c     lesnoe(1) = sommet a joindre au milieu de l'arete coupee pour
 229 c               definir l'arete interne
 230       lesnoe(1) = listso(3)
 231 c
 232 #ifdef _DEBUG_HOMARD_
 233       write(ulsort,90002) 'noemil', noemil
 234       write(ulsort,90002) 'lesnoe(1)', lesnoe(1)
 235 #endif
 236 c
 237 c 2.3. ==> Triangles et aretes tracees sur les faces coupees
 238 c     Sens positif : (S4,S6,S5)
 239 c
 240 c     trifad(1,0) = triangle central de la face 1 : FF4
 241 c     trifad(1,1) = triangle de la face 1 du cote de S4 : FF4 + 1/2
 242 c     trifad(1,2) = triangle de la face 1 du cote de S5 : FF4 + 2/1
 243 c     areqtr(1,1) : AS1N5
 244 c     areqtr(1,2) : AS2N5
 245 c
 246 c     trifad(2,0) = triangle 1 de la face 2 : FF2 + 0/1 (FF2D4)
 247 c     trifad(2,1) = triangle 2 de la face 2 : FF2 + 1/0 (FF2D6)
 248 c     areqtr(2,2) : AS6N5
 249 c
 250       if ( codret.eq.0 ) then
 251 c
 252       nulofa(1) = 4
 253       nulofa(2) = 2
 254 c
 255       ind001(1) = 3
 256       ind001(2) = 2
 257 c
 258 #ifdef _DEBUG_HOMARD_
 259       write (ulsort,texte(langue,3)) 'CMCP0B', nompro
 260 #endif
 261       call cmcp0b ( nulofa, lepent,
 262      >              i3, i1, i2,
 263      >              ind001,
 264      >              somare,
 265      >              aretri, nivtri, filtri,
 266      >              filqua,
 267      >              facpen, cofape,
 268      >              niveau,
 269      >              trifad, cotrvo, areqtr,
 270      >              ulsort, langue, codret )
 271 c
 272       endif
 273 c
 274 c====
 275 c 3. Creation du noeud interne
 276 c====
 277 c====
 278 c 4. Creation de l'arete interne
 279 c    noemil : N5
 280 c    lesnoe(1) : S3
 281 c    areint(1) : AS3N5
 282 c====
 283 #ifdef _DEBUG_HOMARD_
 284       write (ulsort,91000) indare+1, indare+1
 285 #endif
 286 c
 287       if ( codret.eq.0 ) then
 288 c
 289 #ifdef _DEBUG_HOMARD_
 290       write (ulsort,texte(langue,3)) 'CMCHPA', nompro
 291 #endif
 292       iaux = 1
 293       call cmchpa ( indare, iaux,
 294      >              noemil, lesnoe, areint,
 295      >              hetare, somare,
 296      >              filare, merare, famare,
 297      >              ulsort, langue, codret )
 298 c
 299 #ifdef _DEBUG_HOMARD_
 300       write(ulsort,90006) 'areint(1) = ', areint(1),
 301      >                   ' de ',somare(1,areint(1)),
 302      >                   ' a ',somare(2,areint(1))
 303 #endif
 304 c
 305       endif
 306 c
 307 c====
 308 c 5. Creation des trois triangles internes
 309 c    triint(1) : FA1N6
 310 c    triint(2) : FA9N6
 311 c    triint(3) : FA3N6
 312 c====
 313 #ifdef _DEBUG_HOMARD_
 314       write (ulsort,92000) indtri+1, indtri+3
 315 #endif
 316 c
 317       if ( codret.eq.0 ) then
 318 c
 319       lesare(1) = listar(1)
 320       lesare(2) = listar(9)
 321       lesare(3) = listar(3)
 322 c
 323 #ifdef _DEBUG_HOMARD_
 324       write (ulsort,texte(langue,3)) 'CMCP0C', nompro
 325 #endif
 326       call cmcp0c ( indtri, triint,
 327      >              lesare,
 328      >              areint, areqtr, niveau,
 329      >              aretri, famtri, hettri,
 330      >              filtri, pertri, nivtri,
 331      >              ulsort, langue, codret )
 332 c
 333 #ifdef _DEBUG_HOMARD_
 334       do 500 , iaux = indtri-2 , indtri
 335       write (ulsort,90015) 'Triangle', iaux,
 336      >                ', aretes', (aretri(iaux,jaux),jaux=1,3)
 337   500 continue
 338 #endif
 339 c
 340       endif
 341 c
 342 c====
 343 c 6. Creation des deux pyramides
 344 c====
 345 c
 346 #ifdef _DEBUG_HOMARD_
 347       write (ulsort,95000) indpyr+1, indpyr+2
 348 #endif
 349 c
 350       if ( codret.eq.0 ) then
 351 c
 352       laface(1) = f3
 353       coface(1) = per002(3,cf3)
 354 c
 355       laface(2) = f5
 356       coface(2) = per002(3,cf5)
 357 c
 358 #ifdef _DEBUG_HOMARD_
 359       write (ulsort,texte(langue,3)) 'CMCP0D', nompro
 360 #endif
 361       call cmcp0d ( indpyr, indptp,
 362      >              lepent,
 363      >              trifad, cotrvo, triint,
 364      >              laface, coface,
 365      >              hetpyr, facpyr, cofapy,
 366      >              filpyr, perpyr, fampyr,
 367      >              fampen, cfapen,
 368      >              ulsort, langue, codret )
 369 c
 370 #ifdef _DEBUG_HOMARD_
 371       do 600 , iaux = indpyr-1 , indpyr
 372         write (ulsort,90015) 'Pyra', iaux,
 373      >                ', faces', (facpyr(iaux,jaux),jaux=1,5)
 374         write(ulsort,90015) 'Pyra', iaux,
 375      >                ', codes', (cofapy(iaux,jaux),jaux=1,5)
 376   600 continue
 377 #endif
 378 c
 379       endif
 380 c
 381 c====
 382 c 7. Creation du tetraedre
 383 c====
 384 c
 385 #ifdef _DEBUG_HOMARD_
 386       write (ulsort,93000) indtet+1, indtet+1
 387 #endif
 388 c
 389       if ( codret.eq.0 ) then
 390 c
 391       nupere = -indptp
 392       nufami = cfapen(coftfp,fampen(lepent))
 393 c
 394       coface(1) = per001(4,cf1)
 395       indtet = indtet + 1
 396 #ifdef _DEBUG_HOMARD_
 397       write (ulsort,texte(langue,3)) 'CMCTET', nompro
 398 #endif
 399       call cmctet ( tritet, cotrte, famtet,
 400      >              hettet, filtet, pertet,
 401      >                  f1, trifad(1,0), triint(3), triint(1),
 402      >           coface(1), cotrvo(1,0),         1,         6,
 403      >           nupere, nufami, indtet )
 404 c
 405 #ifdef _DEBUG_HOMARD_
 406       do 700 , iaux = indtet , indtet
 407         write (ulsort,90015) 'Tetra', iaux,
 408      >                ', faces', (tritet(iaux,jaux),jaux=1,4)
 409         write (ulsort,90015) 'Tetra', iaux,
 410      >                ', codes', (cotrte(iaux,jaux),jaux=1,4)
 411   700 continue
 412 #endif
 413 c
 414       endif
 415 c
 416 c====
 417 c 8. la fin
 418 c====
 419 c
 420       if ( codret.ne.0 ) then
 421 c
 422 #include "envex2.h"
 423 c
 424       write (ulsort,texte(langue,1)) 'Sortie', nompro
 425       write (ulsort,texte(langue,2)) codret
 426 c
 427       endif
 428 c
 429 #ifdef _DEBUG_HOMARD_
 430       write (ulsort,texte(langue,1)) 'Sortie', nompro
 431       call dmflsh (iaux)
 432 #endif
 433 c
 434       end