src/tool/Creation_Maillage/cmcp01.F

   1       subroutine cmcp01 ( 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 01 - par l'arete de triangle 1
  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 = 'CMCP01' )
 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 "i1i2i3.h"
 122 #include "coftfp.h"
 123 c
 124 c 0.3. ==> arguments
 125 c
 126       integer lepent
 127       integer listar(9), listso(6)
 128       integer indare, indtri, indtet, indpyr
 129       integer indptp
 130       integer hetare(nouvar), somare(2,nouvar)
 131       integer filare(nouvar), merare(nouvar), famare(nouvar)
 132       integer hettri(nouvtr), aretri(nouvtr,3)
 133       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 134       integer nivtri(nouvtr)
 135       integer filqua(nouvqu)
 136       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 137       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 138       integer hetpyr(nouvpy), facpyr(nouvyf,5), cofapy(nouvyf,5)
 139       integer filpyr(nouvpy), perpyr(nouvpy), fampyr(nouvpy)
 140       integer facpen(nouvpf,5), cofape(nouvpf,5)
 141       integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
 142 c
 143       integer ulsort, langue, codret
 144 c
 145 c 0.4. ==> variables locales
 146 c
 147       integer iaux, jaux
 148       integer nupere, nufami
 149       integer f2, cf2
 150       integer f4, cf4
 151       integer f5, cf5
 152 #ifdef _DEBUG_HOMARD_
 153       integer f1, cf1
 154       integer f3, cf3
 155 #endif
 156       integer noemil, lesnoe(2), lesare(3)
 157       integer areint(1)
 158       integer triint(3)
 159       integer laface(2), coface(2)
 160       integer trifad(2,0:2), cotrvo(2,0:2), areqtr(2,2)
 161       integer nulofa(2)
 162       integer ind001(2)
 163       integer niveau
 164 c
 165       integer nbmess
 166       parameter ( nbmess = 10 )
 167       character*80 texte(nblang,nbmess)
 168 c
 169 c 0.5. ==> initialisations
 170 c ______________________________________________________________________
 171 c
 172 c====
 173 c 1. messages
 174 c====
 175 c
 176 #include "impr01.h"
 177 c
 178 #ifdef _DEBUG_HOMARD_
 179       write (ulsort,texte(langue,1)) 'Entree', nompro
 180       call dmflsh (iaux)
 181 #endif
 182 c
 183 #include "impr03.h"
 184 #include "impr04.h"
 185 c
 186       codret = 0
 187 c
 188 c====
 189 c 2. initialisations
 190 c====
 191 #ifdef _DEBUG_HOMARD_
 192       write(ulsort,90002) 'listso', listso
 193 #endif
 194 c
 195 c 2.1. ==> grandeurs independantes du cas traite (phase 1)
 196 c          les faces du pentaedre et leurs codes
 197 c
 198       f2 = facpen(lepent,2)
 199       f4 = facpen(lepent,4)
 200       f5 = facpen(lepent,5)
 201       cf2 = cofape(lepent,2)
 202       cf4 = cofape(lepent,4)
 203       cf5 = cofape(lepent,5)
 204 #ifdef _DEBUG_HOMARD_
 205       f1 = facpen(lepent,1)
 206       f3 = facpen(lepent,3)
 207       cf1 = cofape(lepent,1)
 208       cf3 = cofape(lepent,3)
 209       write(ulsort,90002) 'f1', f1, cf1
 210       write(ulsort,90002) 'f2', f2, cf2
 211       write(ulsort,90002) 'f3', f3, cf3
 212       write(ulsort,90002) 'f4', f4, cf4
 213       write(ulsort,90002) 'f5', f5, cf5
 214 #endif
 215 c
 216 c 2.2. ==> grandeurs dependant du cas traite
 217 c     iaux = numero local de l'arete coupee
 218 c     jaux = numero global de l'arete coupee
 219 c     noemil = noeud milieu de l'arete coupee
 220 c
 221       iaux = 1
 222       jaux = listar(iaux)
 223       noemil = somare(2,filare(jaux))
 224 c
 225 c     lesnoe(1) = sommet a joindre au milieu de l'arete coupee pour
 226 c               definir l'arete interne
 227       lesnoe(1) = listso(5)
 228 c
 229 #ifdef _DEBUG_HOMARD_
 230       write(ulsort,90002) 'noemil', noemil
 231       write(ulsort,90002) 'lesnoe(1)', lesnoe(1)
 232 #endif
 233 c
 234 c 2.3. ==> Triangles et aretes tracees sur les faces coupees
 235 c     Sens positif : (S1,S2,S3)
 236 c
 237 c     trifad(1,0) = triangle central de la face 1 : FF3
 238 c     trifad(1,1) = triangle de la face 1 du cote de S1 : FF3 + 1/2
 239 c     trifad(1,2) = triangle de la face 1 du cote de S3 : FF3 + 2/1
 240 c     areqtr(1,1) : AS4N1
 241 c     areqtr(1,2) : AS6N1
 242 c
 243 c     trifad(2,0) = triangle 1 de la face 2 : FF1 + 0/1 (FF1D2)
 244 c     trifad(2,1) = triangle 2 de la face 2 : FF1 + 1/0 (FF1D3)
 245 c     areqtr(2,2) : AS2N1
 246 c
 247       if ( codret.eq.0 ) then
 248 c
 249       nulofa(1) = 3
 250       nulofa(2) = 1
 251 c
 252       ind001(1) = 2
 253       ind001(2) = 1
 254 c
 255 #ifdef _DEBUG_HOMARD_
 256       write (ulsort,texte(langue,3)) 'CMCP0B', nompro
 257 #endif
 258       call cmcp0b ( nulofa, lepent,
 259      >              i1, i2, i3,
 260      >              ind001,
 261      >              somare,
 262      >              aretri, nivtri, filtri,
 263      >              filqua,
 264      >              facpen, cofape,
 265      >              niveau,
 266      >              trifad, cotrvo, areqtr,
 267      >              ulsort, langue, codret )
 268 c
 269       endif
 270 c
 271 c====
 272 c 3. Creation du noeud interne
 273 c====
 274 c====
 275 c 4. Creation de l'arete interne
 276 c    noemil : N1
 277 c    lesnoe(1) : S5
 278 c    areint(1) : AS5N1
 279 c====
 280 #ifdef _DEBUG_HOMARD_
 281       write (ulsort,91000) indare+1, indare+1
 282 #endif
 283 c
 284       if ( codret.eq.0 ) then
 285 c
 286 #ifdef _DEBUG_HOMARD_
 287       write (ulsort,texte(langue,3)) 'CMCHPA', nompro
 288 #endif
 289       iaux = 1
 290       call cmchpa ( indare, iaux,
 291      >              noemil, lesnoe, areint,
 292      >              hetare, somare,
 293      >              filare, merare, famare,
 294      >              ulsort, langue, codret )
 295 c
 296 #ifdef _DEBUG_HOMARD_
 297       write(ulsort,90006) 'areint(1) = ', areint(1),
 298      >                   ' de ',somare(1,areint(1)),
 299      >                   ' a ',somare(2,areint(1))
 300 #endif
 301 c
 302       endif
 303 c
 304 c====
 305 c 5. Creation des trois triangles internes
 306 c    triint(1) : FA5N1
 307 c    triint(2) : FA8N1
 308 c    triint(3) : FA6N1
 309 c====
 310 #ifdef _DEBUG_HOMARD_
 311       write (ulsort,92000) indtri+1, indtri+3
 312 #endif
 313 c
 314       if ( codret.eq.0 ) then
 315 c
 316       lesare(1) = listar(5)
 317       lesare(2) = listar(8)
 318       lesare(3) = listar(6)
 319 c
 320 #ifdef _DEBUG_HOMARD_
 321       write (ulsort,texte(langue,3)) 'CMCP0C', nompro
 322 #endif
 323       call cmcp0c ( indtri, triint,
 324      >              lesare,
 325      >              areint, areqtr, niveau,
 326      >              aretri, famtri, hettri,
 327      >              filtri, pertri, nivtri,
 328      >              ulsort, langue, codret )
 329 c
 330 #ifdef _DEBUG_HOMARD_
 331       do 500 , iaux = indtri-2 , indtri
 332       write (ulsort,90015) 'Triangle', iaux,
 333      >                ', aretes', (aretri(iaux,jaux),jaux=1,3)
 334   500 continue
 335 #endif
 336 c
 337       endif
 338 c
 339 c====
 340 c 6. Creation des deux pyramides
 341 c====
 342 c
 343 #ifdef _DEBUG_HOMARD_
 344       write (ulsort,95000) indpyr+1, indpyr+2
 345 #endif
 346 c
 347       if ( codret.eq.0 ) then
 348 c
 349       laface(1) = f4
 350       coface(1) = cf4
 351 c
 352       laface(2) = f5
 353       coface(2) = cf5
 354 c
 355 #ifdef _DEBUG_HOMARD_
 356       write (ulsort,texte(langue,3)) 'CMCP0D', nompro
 357 #endif
 358       call cmcp0d ( indpyr, indptp,
 359      >              lepent,
 360      >              trifad, cotrvo, triint,
 361      >              laface, coface,
 362      >              hetpyr, facpyr, cofapy,
 363      >              filpyr, perpyr, fampyr,
 364      >              fampen, cfapen,
 365      >              ulsort, langue, codret )
 366 c
 367 #ifdef _DEBUG_HOMARD_
 368       do 600 , iaux = indpyr-1 , indpyr
 369         write (ulsort,90015) 'Pyra', iaux,
 370      >                ', faces', (facpyr(iaux,jaux),jaux=1,5)
 371         write(ulsort,90015) 'Pyra', iaux,
 372      >                ', codes', (cofapy(iaux,jaux),jaux=1,5)
 373   600 continue
 374 #endif
 375 c
 376       endif
 377 c
 378 c====
 379 c 7. Creation du tetraedre
 380 c====
 381 c
 382 #ifdef _DEBUG_HOMARD_
 383       write (ulsort,93000) indtet+1, indtet+1
 384 #endif
 385 c
 386       if ( codret.eq.0 ) then
 387 c
 388       nupere = -indptp
 389       nufami = cfapen(coftfp,fampen(lepent))
 390 c
 391       coface(1) = per001(5,cf2)
 392       indtet = indtet + 1
 393 #ifdef _DEBUG_HOMARD_
 394       write (ulsort,texte(langue,3)) 'CMCTET', nompro
 395 #endif
 396       call cmctet ( tritet, cotrte, famtet,
 397      >              hettet, filtet, pertet,
 398      >                  f2, trifad(1,0), triint(3), triint(1),
 399      >           coface(1), cotrvo(1,0),         1,         6,
 400      >           nupere, nufami, indtet )
 401 c
 402 #ifdef _DEBUG_HOMARD_
 403       do 700 , iaux = indtet , indtet
 404         write (ulsort,90015) 'Tetra', iaux,
 405      >                ', faces', (tritet(iaux,jaux),jaux=1,4)
 406         write (ulsort,90015) 'Tetra', iaux,
 407      >                ', codes', (cotrte(iaux,jaux),jaux=1,4)
 408   700 continue
 409 #endif
 410 c
 411       endif
 412 c
 413 c====
 414 c 8. la fin
 415 c====
 416 c
 417       if ( codret.ne.0 ) then
 418 c
 419 #include "envex2.h"
 420 c
 421       write (ulsort,texte(langue,1)) 'Sortie', nompro
 422       write (ulsort,texte(langue,2)) codret
 423 c
 424       endif
 425 c
 426 #ifdef _DEBUG_HOMARD_
 427       write (ulsort,texte(langue,1)) 'Sortie', nompro
 428       call dmflsh (iaux)
 429 #endif
 430 c
 431       end