src/tool/Creation_Maillage/cmcp44.F

   1       subroutine cmcp44 ( 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 44 - par la face F4
  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 = 'CMCP44' )
 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 cf4
 152 #ifdef _DEBUG_HOMARD_
 153       integer f1, cf1
 154       integer f2, cf2
 155       integer f3, cf3
 156       integer f4
 157       integer f5, cf5
 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       cf4 = cofape(lepent,4)
 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       f5 = facpen(lepent,5)
 207       cf5 = cofape(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(3)
 221       lesnoe(2) = listso(6)
 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 : FF5
 230 c     trifad(1,1) = triangle de la face 1 bordant F1 : FF5 + 1/2
 231 c     trifad(1,2) = triangle de la face 1 bordant F2 : FF5 + 2/1
 232 c     areqtr(1,1) : AS3N8
 233 c     areqtr(1,2) : AS6N8
 234 c
 235 c     trifad(2,0) = triangle central de la face 2 : FF3
 236 c     trifad(2,1) = triangle de la face 2 bordant F1 : FF3 + 2/1
 237 c     trifad(2,2) = triangle de la face 2 bordant F2 : FF3 + 1/2
 238 c     areqtr(2,1) : AS3N7
 239 c     areqtr(2,2) : AS6N7
 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 : AS3N2
 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 : AS6N5
 248 c
 249 c     quafad(1) = quadrangle de la face 5 : FF4 + 0/1/2/3
 250 c     quafad(2) = quadrangle de la face 5 autre : FF4 + 1/2/3/0
 251 c     quafad(3) = quadrangle de la face 5 autre : FF4 + 2/3/0/1
 252 c     quafad(4) = quadrangle de la face 5 autre : FF4 + 3/0/1/2
 253 c     areqqu(p) : arete commune a quafad(p) et quafad(p+1)
 254 c     areqqu(1) : AN2N0
 255 c     areqqu(2) : AN7N0
 256 c     areqqu(3) : AN5N0
 257 c     areqqu(4) : AN8N0
 258 c
 259       if ( codret.eq.0 ) then
 260 c
 261       nulofa(1) = 5
 262       nulofa(2) = 3
 263       nulofa(3) = 1
 264       nulofa(4) = 2
 265       nulofa(5) = 4
 266 c
 267       tabind(1) = 2
 268       tabind(2) = 1
 269       tabind(3) = 1
 270       tabind(4) = 3
 271 c
 272 #ifdef _DEBUG_HOMARD_
 273       write (ulsort,texte(langue,3)) 'CMCP4B', nompro
 274 #endif
 275       call cmcp4b ( nulofa, lepent,
 276      >              i2, i3, i1,
 277      >              i3, i2, i1,
 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) : AS3N0
 297 c    areint(2) : AS6N0
 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) = FS3N8
 320 c      triint( 2) = FS3N7
 321 c      triint( 3) = FS6N8
 322 c      triint( 4) = FS6N7
 323 c      triint( 5) = FS3N2
 324 c      triint( 6) = FS6N5
 325 c      triint( 7) = FA9
 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(9)
 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 = cf4
 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 c
 370 #ifdef _DEBUG_HOMARD_
 371       do 600 , iaux = indpyr-3 , 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 des tetraedres
 383 c====
 384 c
 385 #ifdef _DEBUG_HOMARD_
 386       write (ulsort,93000) indtet+1, indtet+2
 387 #endif
 388 c
 389       if ( codret.eq.0 ) then
 390 c
 391 #ifdef _DEBUG_HOMARD_
 392       write (ulsort,texte(langue,3)) 'CMCP4E', nompro
 393 #endif
 394       call cmcp4e ( indtet, indptp,
 395      >              lepent,
 396      >              trifad, cotrvo, triint,
 397      >              hettet, tritet, cotrte,
 398      >              filtet, pertet, famtet,
 399      >              fampen, cfapen,
 400      >              ulsort, langue, codret )
 401 c
 402 #ifdef _DEBUG_HOMARD_
 403       do 700 , iaux = indtet-1 , 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