src/tool/Creation_Maillage/cmcp35.F

   1       subroutine cmcp35 ( lepent, listar, listso,
   2      >                    indnoe, indare, indtri, indtet, indpyr,
   3      >                    indptp,
   4      >                    coonoe, hetnoe, arenoe,
   5      >                    famnoe,
   6      >                    hetare, somare,
   7      >                    filare, merare, famare,
   8      >                    hettri, aretri,
   9      >                    filtri, pertri, famtri,
  10      >                    nivtri,
  11      >                    filqua,
  12      >                    hettet, tritet, cotrte,
  13      >                    filtet, pertet, famtet,
  14      >                    hetpyr, facpyr, cofapy,
  15      >                    filpyr, perpyr, fampyr,
  16      >                    facpen, cofape,
  17      >                    fampen, cfapen,
  18      >                    ulsort, langue, codret )
  19 c ______________________________________________________________________
  20 c
  21 c                             H O M A R D
  22 c
  23 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  24 c
  25 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  26 c aupres des huissiers de justice Simart et Lavoir a Clamart
  27 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  28 c aupres des huissiers de justice
  29 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  30 c
  31 c    HOMARD est une marque deposee d'Electricite de France
  32 c
  33 c Copyright EDF 1996
  34 c Copyright EDF 1998
  35 c Copyright EDF 2002
  36 c Copyright EDF 2020
  37 c ______________________________________________________________________
  38 c
  39 c    Creation du Maillage - Conformite - decoupage des Pentaedres
  40 c    -           -          -                          -
  41 c                         - etat 35 - par les aretes 2 et 4
  42 c                                --
  43 c ______________________________________________________________________
  44 c .        .     .        .                                            .
  45 c .  nom   . e/s . taille .           description                      .
  46 c .____________________________________________________________________.
  47 c . lepent . e   .   1    . pentaedre a decouper                       .
  48 c . listar . e   .   9   . liste des aretes du pentaedre a decouper    .
  49 c . listso . e   .   6    . liste des sommets du pentaedre a decouper  .
  50 c . indnoe . es  .   1    . indice du dernier noeud cree               .
  51 c . indare . es  .   1    . indice de la derniere arete creee          .
  52 c . indtri . es  .   1    . indice du dernier triangle cree            .
  53 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  54 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  55 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  56 c . coonoe . es  .nouvno*3. coordonnees des noeuds                     .
  57 c . hetnoe . es  . nouvno . historique de l'etat des noeuds            .
  58 c . arenoe . es  . nouvno . arete liee a un nouveau noeud              .
  59 c . famnoe . es  . nouvno . famille des noeuds                         .
  60 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  61 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  62 c . filare . es  . nouvar . premiere fille des aretes                  .
  63 c . merare . es  . nouvar . mere des aretes                            .
  64 c . famare .     . nouvar . famille des aretes                         .
  65 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  66 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  67 c . filtri . es  . nouvtr . premier fils des triangles                 .
  68 c . pertri . es  . nouvtr . pere des triangles                         .
  69 c . famtri . es  . nouvtr . famille des triangles                      .
  70 c . nivtri . es  . nouvtr . niveau des triangles                       .
  71 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  72 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  73 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  74 c . cotrte . e   .nouvtf*4. code des 4 triangles des tetraedres        .
  75 c . filtet . es  . nouvte . premier fils des tetraedres                .
  76 c . pertet . es  . nouvte . pere des tetraedres                        .
  77 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  78 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  79 c . famtet . es  . nouvte . famille des tetraedres                     .
  80 c . hetpyr . es  . nouvpy . historique de l'etat des pyramides         .
  81 c . facpyr . es  .nouvyf*5. numeros des 5 faces des pyramides          .
  82 c . cofapy . es  .nouvyf*5. codes des faces des pyramides              .
  83 c . filpyr . es  . nouvpy . premier fils des pyramides                 .
  84 c . perpyr . es  . nouvpy . pere des pyramides                         .
  85 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  86 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  87 c . fampyr . es  . nouvpy . famille des pyramides                      .
  88 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  89 c . cofape . e   .nouvpf*5. codes des faces des pentaedres             .
  90 c . fampen . e   . nouvpe . famille des penaedres                      .
  91 c . cfapen . e   . nctfpe*. codes des familles des pentaedres          .
  92 c .        .     . nbfpen .   1 : famille MED                          .
  93 c .        .     .        .   2 : type de pentaedres                   .
  94 c .        .     .        .   3 : famille des tetraedres de conformite .
  95 c .        .     .        .   4 : famille des pyramides de conformite  .
  96 c .        .     .        .   3 : famille des tetraedres de conformite .
  97 c .        .     .        .   4 : famille des pyramides de conformite  .
  98 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  99 c . langue . e   .    1   . langue des messages                        .
 100 c .        .     .        . 1 : francais, 2 : anglais                  .
 101 c . codret . es  .    1   . code de retour des modules                 .
 102 c .        .     .        . 0 : pas de probleme                        .
 103 c .        .     .        . 1 : aucune face ne correspond              .
 104 c ______________________________________________________________________
 105 c
 106 c====
 107 c 0. declarations et dimensionnement
 108 c====
 109 c
 110 c 0.1. ==> generalites
 111 c
 112       implicit none
 113       save
 114 c
 115       character*6 nompro
 116       parameter ( nompro = 'CMCP35' )
 117 c
 118 #include "nblang.h"
 119 c
 120 c 0.2. ==> communs
 121 c
 122 #include "envex1.h"
 123 c
 124 #include "envca1.h"
 125 #include "dicfen.h"
 126 #include "nbfami.h"
 127 #include "nouvnb.h"
 128 #include "i1i2i3.h"
 129 #include "cofpfp.h"
 130 c
 131 c 0.3. ==> arguments
 132 c
 133       integer lepent
 134       integer listar(9), listso(6)
 135       integer indnoe, indare, indtri, indtet, indpyr
 136       integer indptp
 137       integer hetnoe(nouvno), arenoe(nouvno)
 138       integer famnoe(nouvno)
 139       integer hetare(nouvar), somare(2,nouvar)
 140       integer filare(nouvar), merare(nouvar), famare(nouvar)
 141       integer hettri(nouvtr), aretri(nouvtr,3)
 142       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 143       integer nivtri(nouvtr)
 144       integer filqua(nouvqu)
 145       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 146       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 147       integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
 148       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 149       integer facpen(nouvpf,5), cofape(nouvpf,5)
 150       integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
 151 c
 152       double precision coonoe(nouvno,sdim)
 153 c
 154       integer ulsort, langue, codret
 155 c
 156 c 0.4. ==> variables locales
 157 c
 158       integer nbsomm
 159       parameter ( nbsomm = 6 )
 160 c
 161       integer iaux, jaux
 162       integer f5, cf5
 163 #ifdef _DEBUG_HOMARD_
 164       integer f1, cf1
 165       integer f2, cf2
 166       integer f3, cf3
 167       integer f4, cf4
 168 #endif
 169       integer lesnoe(8), lesare(7)
 170       integer areint(8)
 171       integer triint(17)
 172       integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2)
 173       integer nulofa(4)
 174       integer ind001(4)
 175       integer niveau
 176 c
 177       integer nbmess
 178       parameter ( nbmess = 10 )
 179       character*80 texte(nblang,nbmess)
 180 c
 181 c 0.5. ==> initialisations
 182 c ______________________________________________________________________
 183 c
 184 c====
 185 c 1. messages
 186 c====
 187 c
 188 #include "impr01.h"
 189 c
 190 #ifdef _DEBUG_HOMARD_
 191       write (ulsort,texte(langue,1)) 'Entree', nompro
 192       call dmflsh (iaux)
 193 #endif
 194 c
 195 #include "impr03.h"
 196 #include "impr04.h"
 197 c
 198       codret = 0
 199 c
 200 c====
 201 c 2. initialisations
 202 c====
 203 c 2.1. ==> grandeurs independantes du cas traite (phase 1)
 204 c          les faces du pentaedre et leurs codes
 205 c
 206       f5 = facpen(lepent,5)
 207       cf5 = cofape(lepent,5)
 208 #ifdef _DEBUG_HOMARD_
 209       f1 = facpen(lepent,1)
 210       cf1 = cofape(lepent,1)
 211       f2 = facpen(lepent,2)
 212       cf2 = cofape(lepent,2)
 213       f3 = facpen(lepent,3)
 214       cf3 = cofape(lepent,3)
 215       f4 = facpen(lepent,4)
 216       cf4 = cofape(lepent,4)
 217       write(ulsort,90002) 'f1', f1, cf1
 218       write(ulsort,90002) 'f2', f2, cf2
 219       write(ulsort,90002) 'f3', f3, cf3
 220       write(ulsort,90002) 'f4', f4, cf4
 221       write(ulsort,90002) 'f5', f5, cf5
 222 #endif
 223 c
 224 c 2.2. ==> grandeurs dependant du cas traite
 225 c     iaux = numero local de l'arete coupee
 226 c     jaux = numero global de l'arete coupee
 227 c     noemil = noeud milieu de l'arete coupee
 228 c
 229       iaux = 2
 230       jaux = listar(iaux)
 231       lesnoe(7) = somare(2,filare(jaux))
 232 c
 233       iaux = 4
 234       jaux = listar(iaux)
 235       lesnoe(8) = somare(2,filare(jaux))
 236 c
 237 c     lesnoe(i) = sommet a joindre au centre du pentaedre pour creer
 238 c                 l'arete interne i
 239 c      Les 4 premiers sont les sommets Si de la pyramide
 240 c      lesnoe(5) : le dernier sommet de la face 1
 241 c      lesnoe(6) : le dernier sommet de la face 2
 242 c
 243       lesnoe(1) = listso(3)
 244       lesnoe(2) = listso(2)
 245       lesnoe(3) = listso(5)
 246       lesnoe(4) = listso(6)
 247       lesnoe(5) = listso(1)
 248       lesnoe(6) = listso(4)
 249 c
 250 #ifdef _DEBUG_HOMARD_
 251       write(ulsort,90002) 'lesnoe', lesnoe
 252 #endif
 253 c
 254 c 2.3. ==> Triangles et aretes tracees sur les faces coupees
 255 c
 256 c     trifad(1,0) = triangle central de la face 1 : FF4
 257 c     trifad(1,1) = triangle de la face 1 bordant la pyr : FF4 + 1/2
 258 c     trifad(1,2) = triangle de la face 1 autre : FF4 + 2/1
 259 c     areqtr(1,1) : AS5N2
 260 c     areqtr(1,2) : AS4N2
 261 c
 262 c     trifad(2,0) = triangle central de la face 2 : FF3
 263 c     trifad(2,1) = triangle de la face 2 bordant la pyr : FF3 + 2/1
 264 c     trifad(2,2) = triangle de la face 2 autre : FF3 + 1/2
 265 c     areqtr(2,1) : AS3N4
 266 c     areqtr(2,2) : AS1N4
 267 c
 268 c     trifad(3,0) = triangle de la face 3 bordant la pyr : FF1 + 0/1
 269 c     trifad(3,1) = triangle de la face 3 autre : FF1 + 1/0
 270 c     areqtr(3,0) : arete de trifad(3,0) : AS2N2
 271 c     areqtr(3,1) : arete de trifad(3,1) : AS1N2
 272 c     areqtr(3,2) : arete commune : AS3N2
 273 c
 274 c     trifad(4,0) = triangle de la face 4 bordant la pyr : FF2 + 0/1
 275 c     trifad(4,1) = triangle de la face 4 autre : FF2 + 1/0
 276 c     areqtr(4,0) : arete de trifad(4,0) : AS6N4
 277 c     areqtr(4,1) : arete de trifad(4,1) : AS4N4
 278 c     areqtr(4,2) : arete commune : AS5N4
 279 c
 280       if ( codret.eq.0 ) then
 281 c
 282       nulofa(1) = 4
 283       nulofa(2) = 3
 284       nulofa(3) = 1
 285       nulofa(4) = 2
 286 c
 287       ind001(1) = 6
 288       ind001(2) = 5
 289       ind001(3) = 4
 290       ind001(4) = 6
 291 c
 292 #ifdef _DEBUG_HOMARD_
 293       write (ulsort,texte(langue,3)) 'CMCP3F', nompro
 294 #endif
 295       call cmcp3f ( nulofa, lepent,
 296      >              i2, i3, i1,
 297      >              i1, i2, i3,
 298      >              ind001,
 299      >              somare,
 300      >              aretri, nivtri, filtri,
 301      >              filqua,
 302      >              facpen, cofape,
 303      >              niveau,
 304      >              trifad, cotrvo, areqtr,
 305      >              ulsort, langue, codret )
 306 c
 307       endif
 308 c
 309 c====
 310 c 3. Creation du noeud interne
 311 c 4. Creation des aretes internes
 312 c    areint(1) : AS3N0
 313 c    areint(2) : AS2N0
 314 c    areint(3) : AS5N0
 315 c    areint(4) : AS6N0
 316 c    areint(5) : AS1N0
 317 c    areint(6) : AS4N0
 318 c    areint(7) : AN2N0
 319 c    areint(8) : AN4N0
 320 c====
 321 #ifdef _DEBUG_HOMARD_
 322       write (ulsort,98000) indnoe+1, indnoe+1
 323       write (ulsort,91000) indare+1, indare+8
 324 #endif
 325 c
 326       if ( codret.eq.0 ) then
 327 c
 328 #ifdef _DEBUG_HOMARD_
 329       write (ulsort,texte(langue,3)) 'CMCHPB', nompro
 330 #endif
 331       iaux = 8
 332       call cmchpb ( indnoe, indare, iaux,
 333      >              nbsomm, lesnoe, areint,
 334      >              coonoe, hetnoe, arenoe,
 335      >              famnoe,
 336      >              hetare, somare,
 337      >              filare, merare, famare,
 338      >              ulsort, langue, codret )
 339 c
 340 #ifdef _DEBUG_HOMARD_
 341       do 400 , iaux = indare-7 , indare
 342         write (ulsort,90015) 'Arete', iaux,
 343      >                ', sommets', somare(1,iaux),somare(2,iaux)
 344   400 continue
 345 #endif
 346 c
 347       endif
 348 c
 349 c====
 350 c 5. Creation des 17 triangles internes
 351 c      triint( 1) = FA3
 352 c      triint( 2) = FA8
 353 c      triint( 3) = FA6
 354 c      triint( 4) = FA9
 355 c      triint( 5) = FA1
 356 c      triint( 6) = FA5
 357 c      triint( 7) = FA7
 358 c      triint( 8) = FS2N2
 359 c      triint( 9) = FS1N2
 360 c      triint(10) = FS6N4
 361 c      triint(11) = FS4N4
 362 c      triint(12) = FS5N2
 363 c      triint(13) = FS4N2
 364 c      triint(14) = FS3N4
 365 c      triint(15) = FS1N4
 366 c      triint(16) = FS3N2
 367 c      triint(17) = FS5N4
 368 c====
 369 #ifdef _DEBUG_HOMARD_
 370       write (ulsort,92000) indtri+1, indtri+17
 371 #endif
 372 c
 373       if ( codret.eq.0 ) then
 374 c
 375       lesare(1) = listar(3)
 376       lesare(2) = listar(8)
 377       lesare(3) = listar(6)
 378       lesare(4) = listar(9)
 379       lesare(5) = listar(1)
 380       lesare(6) = listar(5)
 381       lesare(7) = listar(7)
 382 c
 383 #ifdef _DEBUG_HOMARD_
 384       write (ulsort,texte(langue,3)) 'CMCP3G', nompro
 385 #endif
 386       call cmcp3g ( indtri, triint,
 387      >              lesare,
 388      >              areint, areqtr, niveau,
 389      >              aretri, famtri, hettri,
 390      >              filtri, pertri, nivtri,
 391      >              ulsort, langue, codret )
 392 c
 393 #ifdef _DEBUG_HOMARD_
 394       do 500 , iaux = indtri-16 , indtri
 395         write(ulsort,90015) 'tria', iaux,
 396      >                      ' : aretes =', (aretri(iaux,jaux),jaux=1,3)
 397   500 continue
 398 #endif
 399 c
 400       endif
 401 c
 402 c====
 403 c 6. Creation de la pyramide
 404 c====
 405 c
 406 #ifdef _DEBUG_HOMARD_
 407       write (ulsort,95000) indpyr+1, indpyr+1
 408 #endif
 409 c
 410       if ( codret.eq.0 ) then
 411 c
 412       iaux = -indptp
 413       jaux = cfapen(cofpfp,fampen(lepent))
 414 c
 415 #ifdef _DEBUG_HOMARD_
 416       write (ulsort,texte(langue,3)) 'CMCPYR', nompro
 417 #endif
 418       indpyr = indpyr + 1
 419       call cmcpyr ( facpyr, cofapy, fampyr, hetpyr, filpyr, perpyr,
 420      >                triint(1),           2,
 421      >                triint(2),           2,
 422      >                triint(3),           2,
 423      >                triint(4),           1,
 424      >                       f5,         cf5,
 425      >              iaux,  jaux,   indpyr )
 426 c
 427 #ifdef _DEBUG_HOMARD_
 428       do 600 , iaux = indpyr , indpyr
 429         write (ulsort,90015) 'Pyra', iaux,
 430      >                ', faces', (facpyr(iaux,jaux),jaux=1,5)
 431         write(ulsort,90015) 'Pyra', iaux,
 432      >                ', codes', (cofapy(iaux,jaux),jaux=1,5)
 433   600 continue
 434 #endif
 435 c
 436       endif
 437 c
 438 c====
 439 c 7. Creation des tetraedres
 440 c====
 441 c
 442 #ifdef _DEBUG_HOMARD_
 443       write (ulsort,93000) indtet+1, indtet+10
 444 #endif
 445 c
 446       if ( codret.eq.0 ) then
 447 c
 448 #ifdef _DEBUG_HOMARD_
 449       write (ulsort,texte(langue,3)) 'CMCP3H', nompro
 450 #endif
 451       call cmcp3h ( indtet, indptp,
 452      >              lepent,
 453      >              trifad, cotrvo, triint,
 454      >              hettet, tritet, cotrte,
 455      >              filtet, pertet, famtet,
 456      >              fampen, cfapen,
 457      >              ulsort, langue, codret )
 458 c
 459 #ifdef _DEBUG_HOMARD_
 460       do 700 , iaux = indtet-9 , indtet
 461         write (ulsort,90015) 'Tetra', iaux,
 462      >                ', faces', (tritet(iaux,jaux),jaux=1,4)
 463         write(ulsort,90015) 'Tetra', iaux,
 464      >                ', codes', (cotrte(iaux,jaux),jaux=1,4)
 465   700 continue
 466 #endif
 467 c
 468       endif
 469 c
 470 c====
 471 c 8. la fin
 472 c====
 473 c
 474       if ( codret.ne.0 ) then
 475 c
 476 #include "envex2.h"
 477 c
 478       write (ulsort,texte(langue,1)) 'Sortie', nompro
 479       write (ulsort,texte(langue,2)) codret
 480 c
 481       endif
 482 c
 483 #ifdef _DEBUG_HOMARD_
 484       write (ulsort,texte(langue,1)) 'Sortie', nompro
 485       call dmflsh (iaux)
 486 #endif
 487 c
 488       end