src/tool/Creation_Maillage/cmcp45.F

   1       subroutine cmcp45 ( 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      >                    arequa, 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 45 - par la face F5
  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 . 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 . es  . nouvpy . historique de l'etat des pyramides         .
  75 c . facpyr . es  .nouvyf*5. numeros des 5 faces des pyramides          .
  76 c . cofapy . es  .nouvyf*5. codes des faces des pyramides              .
  77 c . filpyr . es  . nouvpy . premier fils des pyramides                 .
  78 c . perpyr . es  . 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 . es  . nouvpy . famille des pyramides                      .
  82 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  83 c . cofape . e   .nouvpf*5. codes des faces des pentaedres             .
  84 c . fampen . e   . nouvpe . famille des penaedres                      .
  85 c . cfapen . e   . nctfpe*. codes des familles des pentaedres          .
  86 c .        .     . nbfpen .   1 : famille MED                          .
  87 c .        .     .        .   2 : type de pentaedres                   .
  88 c .        .     .        .   3 : famille des tetraedres de conformite .
  89 c .        .     .        .   4 : famille des pyramides de conformite  .
  90 c .        .     .        .   3 : famille des tetraedres de conformite .
  91 c .        .     .        .   4 : famille des pyramides de conformite  .
  92 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  93 c . langue . e   .    1   . langue des messages                        .
  94 c .        .     .        . 1 : francais, 2 : anglais                  .
  95 c . codret . es  .    1   . code de retour des modules                 .
  96 c .        .     .        . 0 : pas de probleme                        .
  97 c .        .     .        . 1 : aucune face ne correspond              .
  98 c ______________________________________________________________________
  99 c
 100 c====
 101 c 0. declarations et dimensionnement
 102 c====
 103 c
 104 c 0.1. ==> generalites
 105 c
 106       implicit none
 107       save
 108 c
 109       character*6 nompro
 110       parameter ( nompro = 'CMCP45' )
 111 c
 112 #include "nblang.h"
 113 c
 114 c 0.2. ==> communs
 115 c
 116 #include "envex1.h"
 117 c
 118 #include "dicfen.h"
 119 #include "nbfami.h"
 120 #include "nouvnb.h"
 121 #include "i1i2i3.h"
 122 c
 123 c 0.3. ==> arguments
 124 c
 125       integer lepent
 126       integer listar(9), listso(6)
 127       integer indare, indtri, indtet, indpyr
 128       integer indptp
 129       integer hetare(nouvar), somare(2,nouvar)
 130       integer filare(nouvar), merare(nouvar), famare(nouvar)
 131       integer hettri(nouvtr), aretri(nouvtr,3)
 132       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 133       integer nivtri(nouvtr)
 134       integer arequa(nouvqu,4)
 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
 148 #ifdef _DEBUG_HOMARD_
 149       integer jaux
 150 #endif
 151       integer cf5
 152 #ifdef _DEBUG_HOMARD_
 153       integer f1, cf1
 154       integer f2, cf2
 155       integer f3, cf3
 156       integer f4, cf4
 157       integer f5
 158 #endif
 159       integer noemil, lesnoe(2), lesare(7)
 160       integer areint(8)
 161       integer triint(7)
 162       integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2)
 163       integer quafad(4), areqqu(4)
 164       integer nulofa(5)
 165       integer tabind(4)
 166       integer niveau
 167 c
 168       integer nbmess
 169       parameter ( nbmess = 10 )
 170       character*80 texte(nblang,nbmess)
 171 c
 172 c 0.5. ==> initialisations
 173 c ______________________________________________________________________
 174 c
 175 c====
 176 c 1. messages
 177 c====
 178 c
 179 #include "impr01.h"
 180 c
 181 #ifdef _DEBUG_HOMARD_
 182       write (ulsort,texte(langue,1)) 'Entree', nompro
 183       call dmflsh (iaux)
 184 #endif
 185 c
 186 #include "impr03.h"
 187 #include "impr04.h"
 188 c
 189       codret = 0
 190 c
 191 c====
 192 c 2. initialisations
 193 c====
 194 c 2.1. ==> grandeurs independantes du cas traite (phase 1)
 195 c          les faces du pentaedre et leurs codes
 196 c
 197       cf5 = cofape(lepent,5)
 198 #ifdef _DEBUG_HOMARD_
 199       f1 = facpen(lepent,1)
 200       cf1 = cofape(lepent,1)
 201       f2 = facpen(lepent,2)
 202       cf2 = cofape(lepent,2)
 203       f3 = facpen(lepent,3)
 204       cf3 = cofape(lepent,3)
 205       f4 = facpen(lepent,4)
 206       cf4 = cofape(lepent,4)
 207       f5 = facpen(lepent,5)
 208       write(ulsort,90002) 'f1', f1, cf1
 209       write(ulsort,90002) 'f2', f2, cf2
 210       write(ulsort,90002) 'f3', f3, cf3
 211       write(ulsort,90002) 'f4', f4, cf4
 212       write(ulsort,90002) 'f5', f5, cf5
 213 #endif
 214 c
 215 c 2.2. ==> grandeurs dependant du cas traite
 216 c
 217 c     lesnoe(i) = sommet a joindre au centre de la face quadrangulaire
 218 c                 coupee pour creer l'arete interne i
 219 c
 220       lesnoe(1) = listso(1)
 221       lesnoe(2) = listso(4)
 222 c
 223 #ifdef _DEBUG_HOMARD_
 224       write(ulsort,90002) 'lesnoe', lesnoe
 225 #endif
 226 c
 227 c 2.3. ==> Triangles et aretes tracees sur les faces coupees
 228 c
 229 c     trifad(1,0) = triangle central de la face 1 : FF3
 230 c     trifad(1,1) = triangle de la face 1 bordant F1 : FF3 + 1/2
 231 c     trifad(1,2) = triangle de la face 1 bordant F2 : FF3 + 2/1
 232 c     areqtr(1,1) : AS1N9
 233 c     areqtr(1,2) : AS4N9
 234 c
 235 c     trifad(2,0) = triangle central de la face 2 : FF4
 236 c     trifad(2,1) = triangle de la face 2 bordant F1 : FF4 + 2/1
 237 c     trifad(2,2) = triangle de la face 2 bordant F2 : FF4 + 1/2
 238 c     areqtr(2,1) : AS1N8
 239 c     areqtr(2,2) : AS4N8
 240 c
 241 c     trifad(3,0) = triangle de la face 3 : FF1 + 0/1
 242 c     trifad(3,1) = triangle de la face 3 autre : FF1 + 1/0
 243 c     areqtr(3,2) : arete commune : AS1N3
 244 c
 245 c     trifad(4,0) = triangle de la face 4 : FF2 + 0/1
 246 c     trifad(4,1) = triangle de la face 4 autre : FF2 + 1/0
 247 c     areqtr(4,2) : arete commune : AS4N6
 248 c
 249 c     quafad(1) = quadrangle de la face 5 : FF5 + 0/1/2/3
 250 c     quafad(2) = quadrangle de la face 5 autre : FF5 + 1/2/3/0
 251 c     quafad(3) = quadrangle de la face 5 autre : FF5 + 2/3/0/1
 252 c     quafad(4) = quadrangle de la face 5 autre : FF5 + 3/0/1/2
 253 c     areqqu(p) : arete commune a quafad(p) et quafad(p+1)
 254 c     areqqu(1) : AN3N0
 255 c     areqqu(2) : AN8N0
 256 c     areqqu(3) : AN6N0
 257 c     areqqu(4) : AN9N0
 258 c
 259       if ( codret.eq.0 ) then
 260 c
 261       nulofa(1) = 3
 262       nulofa(2) = 4
 263       nulofa(3) = 1
 264       nulofa(4) = 2
 265       nulofa(5) = 5
 266 c
 267       tabind(1) = 1
 268       tabind(2) = 3
 269       tabind(3) = 2
 270       tabind(4) = 1
 271 c
 272 #ifdef _DEBUG_HOMARD_
 273       write (ulsort,texte(langue,3)) 'CMCP4B', nompro
 274 #endif
 275       call cmcp4b ( nulofa, lepent,
 276      >              i3, i1, i2,
 277      >              i2, i1, i3,
 278      >              tabind,
 279      >              somare,
 280      >              aretri, nivtri, filtri,
 281      >              arequa, filqua,
 282      >              facpen, cofape,
 283      >              noemil,
 284      >              niveau,
 285      >              trifad, cotrvo, areqtr,
 286      >              quafad, areqqu,
 287      >              ulsort, langue, codret )
 288 c
 289       endif
 290 c
 291 c====
 292 c 3. Creation du noeud interne
 293 c====
 294 c====
 295 c 4. Creation des aretes internes
 296 c    areint(1) : AS1N0
 297 c    areint(2) : AS4N0
 298 c====
 299 #ifdef _DEBUG_HOMARD_
 300       write (ulsort,91000) indare+1, indare+2
 301 #endif
 302 c
 303       if ( codret.eq.0 ) then
 304 c
 305 #ifdef _DEBUG_HOMARD_
 306       write (ulsort,texte(langue,3)) 'CMCHPA', nompro
 307 #endif
 308       iaux = 2
 309       call cmchpa ( indare, iaux,
 310      >              noemil, lesnoe, areint,
 311      >              hetare, somare,
 312      >              filare, merare, famare,
 313      >              ulsort, langue, codret )
 314 c
 315       endif
 316 c
 317 c====
 318 c 5. Creation des 7 triangles internes
 319 c      triint( 1) = FS1N9
 320 c      triint( 2) = FS1N8
 321 c      triint( 3) = FS4N9
 322 c      triint( 4) = FS4N8
 323 c      triint( 5) = FS1N3
 324 c      triint( 6) = FS4N6
 325 c      triint( 7) = FA7
 326 c====
 327 #ifdef _DEBUG_HOMARD_
 328       write (ulsort,92000) indtri+1, indtri+7
 329 #endif
 330 c
 331       if ( codret.eq.0 ) then
 332 c
 333       lesare(1) = listar(7)
 334 c
 335 #ifdef _DEBUG_HOMARD_
 336       write (ulsort,texte(langue,3)) 'CMCP4C', nompro
 337 #endif
 338       call cmcp4c ( indtri, triint,
 339      >              lesare,
 340      >              areint, areqtr, areqqu, niveau,
 341      >              aretri, famtri, hettri,
 342      >              filtri, pertri, nivtri,
 343      >              ulsort, langue, codret )
 344       endif
 345 c
 346 c====
 347 c 6. Creation des pyramides
 348 c====
 349 c
 350 #ifdef _DEBUG_HOMARD_
 351       write (ulsort,95000) indpyr+1, indpyr+4
 352 #endif
 353 c
 354       if ( codret.eq.0 ) then
 355 c
 356       iaux = cf5
 357 c
 358 #ifdef _DEBUG_HOMARD_
 359       write (ulsort,texte(langue,3)) 'CMCP4D', nompro
 360 #endif
 361       call cmcp4d ( indpyr, indptp,
 362      >              lepent,
 363      >              trifad, cotrvo, triint,
 364      >              quafad, iaux,
 365      >              hetpyr, facpyr, cofapy,
 366      >              filpyr, perpyr, fampyr,
 367      >              fampen, cfapen,
 368      >              ulsort, langue, codret )
 369 #ifdef _DEBUG_HOMARD_
 370       do 600 , iaux = indpyr-3 , indpyr
 371         write (ulsort,90015) 'Pyra', iaux,
 372      >                ', faces', (facpyr(iaux,jaux),jaux=1,5)
 373         write(ulsort,90015) 'Pyra', iaux,
 374      >                ', codes', (cofapy(iaux,jaux),jaux=1,5)
 375   600 continue
 376 #endif
 377 c
 378       endif
 379 c
 380 c====
 381 c 7. Creation des tetraedres
 382 c====
 383 c
 384 #ifdef _DEBUG_HOMARD_
 385       write (ulsort,93000) indtet+1, indtet+2
 386 #endif
 387 c
 388       if ( codret.eq.0 ) then
 389 c
 390 #ifdef _DEBUG_HOMARD_
 391       write (ulsort,texte(langue,3)) 'CMCP4E', nompro
 392 #endif
 393       call cmcp4e ( indtet, indptp,
 394      >              lepent,
 395      >              trifad, cotrvo, triint,
 396      >              hettet, tritet, cotrte,
 397      >              filtet, pertet, famtet,
 398      >              fampen, cfapen,
 399      >              ulsort, langue, codret )
 400 c
 401 #ifdef _DEBUG_HOMARD_
 402       do 700 , iaux = indtet-1 , indtet
 403         write (ulsort,90015) 'Tetra', iaux,
 404      >                ', faces', (tritet(iaux,jaux),jaux=1,4)
 405         write(ulsort,90015) 'Tetra', iaux,
 406      >                ', codes', (cotrte(iaux,jaux),jaux=1,4)
 407   700 continue
 408 #endif
 409 c
 410       endif
 411 c
 412 c====
 413 c 8. la fin
 414 c====
 415 c
 416       if ( codret.ne.0 ) then
 417 c
 418 #include "envex2.h"
 419 c
 420       write (ulsort,texte(langue,1)) 'Sortie', nompro
 421       write (ulsort,texte(langue,2)) codret
 422 c
 423       endif
 424 c
 425 #ifdef _DEBUG_HOMARD_
 426       write (ulsort,texte(langue,1)) 'Sortie', nompro
 427       call dmflsh (iaux)
 428 #endif
 429 c
 430       end