src/tool/Creation_Maillage/cmcp52.F

   1       subroutine cmcp52 ( lepent, listar, listso,
   2      >                    indnoe, indare, indtri, indtet,
   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      >                    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 52 - par la face F2
  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 . indnoe . es  .   1    . indice du dernier noeud cree               .
  49 c . indare . es  .   1    . indice de la derniere arete creee          .
  50 c . indtri . es  .   1    . indice du dernier triangle cree            .
  51 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  52 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  53 c . coonoe . es  .nouvno*3. coordonnees des noeuds                     .
  54 c . hetnoe . es  . nouvno . historique de l'etat des noeuds            .
  55 c . arenoe . es  . nouvno . arete liee a un nouveau noeud              .
  56 c . famnoe . es  . nouvno . famille des noeuds                         .
  57 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  58 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  59 c . filare . es  . nouvar . premiere fille des aretes                  .
  60 c . merare . es  . nouvar . mere des aretes                            .
  61 c . famare .     . nouvar . famille des aretes                         .
  62 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  63 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  64 c . filtri . es  . nouvtr . premier fils des triangles                 .
  65 c . pertri . es  . nouvtr . pere des triangles                         .
  66 c . famtri . es  . nouvtr . famille des triangles                      .
  67 c . nivtri . es  . nouvtr . niveau des triangles                       .
  68 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  69 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  70 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  71 c . cotrte . e   .nouvtf*4. code des 4 triangles des tetraedres        .
  72 c . filtet . es  . nouvte . premier fils des tetraedres                .
  73 c . pertet . es  . nouvte . pere des tetraedres                        .
  74 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  75 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  76 c . famtet . es  . nouvte . famille des tetraedres                     .
  77 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  78 c . cofape . e   .nouvpf*5. codes des faces des pentaedres             .
  79 c . fampen . e   . nouvpe . famille des penaedres                      .
  80 c . cfapen . e   . nctfpe*. codes des familles des pentaedres          .
  81 c .        .     . nbfpen .   1 : famille MED                          .
  82 c .        .     .        .   2 : type de pentaedres                   .
  83 c .        .     .        .   3 : famille des tetraedres de conformite .
  84 c .        .     .        .   4 : famille des pyramides de conformite  .
  85 c .        .     .        .   3 : famille des tetraedres de conformite .
  86 c .        .     .        .   4 : famille des pyramides de conformite  .
  87 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  88 c . langue . e   .    1   . langue des messages                        .
  89 c .        .     .        . 1 : francais, 2 : anglais                  .
  90 c . codret . es  .    1   . code de retour des modules                 .
  91 c .        .     .        . 0 : pas de probleme                        .
  92 c .        .     .        . 1 : aucune face ne correspond              .
  93 c ______________________________________________________________________
  94 c
  95 c====
  96 c 0. declarations et dimensionnement
  97 c====
  98 c
  99 c 0.1. ==> generalites
 100 c
 101       implicit none
 102       save
 103 c
 104       character*6 nompro
 105       parameter ( nompro = 'CMCP52' )
 106 c
 107 #include "nblang.h"
 108 c
 109 c 0.2. ==> communs
 110 c
 111 #include "envex1.h"
 112 c
 113 #include "envca1.h"
 114 #include "dicfen.h"
 115 #include "nbfami.h"
 116 #include "nouvnb.h"
 117 #include "i1i2i3.h"
 118 #include "ope001.h"
 119 c
 120 c 0.3. ==> arguments
 121 c
 122       integer lepent
 123       integer listar(9), listso(6)
 124       integer indnoe, indare, indtri, indtet
 125       integer indptp
 126       integer hetnoe(nouvno), arenoe(nouvno)
 127       integer famnoe(nouvno)
 128       integer hetare(nouvar), somare(2,nouvar)
 129       integer filare(nouvar), merare(nouvar), famare(nouvar)
 130       integer hettri(nouvtr), aretri(nouvtr,3)
 131       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 132       integer nivtri(nouvtr)
 133       integer filqua(nouvqu)
 134       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 135       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 136       integer facpen(nouvpf,5), cofape(nouvpf,5)
 137       integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
 138 c
 139       double precision coonoe(nouvno,sdim)
 140 c
 141       integer ulsort, langue, codret
 142 c
 143 c 0.4. ==> variables locales
 144 c
 145       integer nbsomm
 146       parameter ( nbsomm = 6 )
 147 c
 148       integer iaux, jaux
 149       integer f1, cf1
 150 #ifdef _DEBUG_HOMARD_
 151       integer f2, cf2
 152       integer f3, cf3
 153       integer f4, cf4
 154       integer f5, cf5
 155 #endif
 156       integer lesnoe(6), lesare(7)
 157       integer areint(8)
 158       integer triint(15)
 159       integer trifad(4,0:3), cotrvo(4,0:3), areqtr(4,0:3)
 160       integer nulofa(4)
 161       integer tabind(0:3)
 162       integer niveau
 163 c
 164       integer nbmess
 165       parameter ( nbmess = 10 )
 166       character*80 texte(nblang,nbmess)
 167 c
 168 c 0.5. ==> initialisations
 169 c ______________________________________________________________________
 170 c
 171 c====
 172 c 1. messages
 173 c====
 174 c
 175 #include "impr01.h"
 176 c
 177 #ifdef _DEBUG_HOMARD_
 178       write (ulsort,texte(langue,1)) 'Entree', nompro
 179       call dmflsh (iaux)
 180 #endif
 181 c
 182 #include "impr03.h"
 183 #include "impr04.h"
 184 c
 185       codret = 0
 186 c
 187 c====
 188 c 2. initialisations
 189 c====
 190 c 2.1. ==> grandeurs independantes du cas traite (phase 1)
 191 c          les faces du pentaedre et leurs codes
 192 c
 193       f1 = facpen(lepent,1)
 194       cf1 = cofape(lepent,1)
 195 #ifdef _DEBUG_HOMARD_
 196       f2 = facpen(lepent,2)
 197       cf2 = cofape(lepent,2)
 198       f3 = facpen(lepent,3)
 199       cf3 = cofape(lepent,3)
 200       f4 = facpen(lepent,4)
 201       cf4 = cofape(lepent,4)
 202       f5 = facpen(lepent,5)
 203       cf5 = cofape(lepent,5)
 204       write(ulsort,90002) 'f1', f1, cf1
 205       write(ulsort,90002) 'f2', f2, cf2
 206       write(ulsort,90002) 'f3', f3, cf3
 207       write(ulsort,90002) 'f4', f4, cf4
 208       write(ulsort,90002) 'f5', f5, cf5
 209 #endif
 210 c
 211 c 2.2. ==> grandeurs dependant du cas traite
 212 c     iaux = numero local de l'arete coupee
 213 c     jaux = numero global de l'arete coupee
 214 c     noemil = noeud milieu de l'arete coupee
 215 c
 216       iaux = 6
 217       jaux = listar(iaux)
 218       lesnoe(4) = somare(2,filare(jaux))
 219 c
 220       iaux = 5
 221       jaux = listar(iaux)
 222       lesnoe(5) = somare(2,filare(jaux))
 223 c
 224       iaux = 4
 225       jaux = listar(iaux)
 226       lesnoe(6) = somare(2,filare(jaux))
 227 c
 228 c     lesnoe(i) = sommet a joindre au centre du pentaedre pour creer
 229 c                 l'arete interne i
 230 c
 231       lesnoe(1) = listso(2)
 232       lesnoe(2) = listso(1)
 233       lesnoe(3) = listso(3)
 234 c
 235 #ifdef _DEBUG_HOMARD_
 236       write(ulsort,90002) 'lesnoe', lesnoe
 237 #endif
 238 c
 239 c 2.3. ==> Triangles et aretes tracees sur les faces coupees
 240 c
 241 c     trifad(1,0) = triangle central de la face 1 : FF5
 242 c     trifad(1,1) = triangle de la face 1 voisin de F4 : FF5 + 1/2
 243 c     trifad(1,2) = triangle de la face 1 voisin de F3 : FF5 + 2/1
 244 c     areqtr(1,1) : AS2N6
 245 c     areqtr(1,2) : AS3N6
 246 c     areqtr(1,0) : AS5N6
 247 c     areqtr(1,3) : AS6N6
 248 c
 249 c     trifad(2,0) = triangle central de la face 2 : FF4
 250 c     trifad(2,1) = triangle de la face 2 voisin de F3 : FF4 + 2/1
 251 c     trifad(2,2) = triangle de la face 2 voisin de F5 : FF4 + 1/2
 252 c     areqtr(2,1) : AS1N5
 253 c     areqtr(2,2) : AS2N5
 254 c     areqtr(2,0) : AS4N5
 255 c     areqtr(2,3) : AS5N5
 256 c
 257 c     trifad(3,0) = triangle central de la face 3 : FF3
 258 c     trifad(3,1) = triangle de la face 3 voisin de F5 : FF3 + 2/1
 259 c     trifad(3,2) = triangle de la face 3 voisin de F4 : FF3 + 1/2
 260 c     areqtr(3,1) : AS3N4
 261 c     areqtr(3,2) : AS1N4
 262 c     areqtr(3,0) : AS6N4
 263 c     areqtr(3,3) : AS4N4
 264 c
 265 c     trifad(4,0) = triangle central de la face decoupee : FF2
 266 c     trifad(4,1) = triangle de la face voisin de F4 et F5 : FF2 + 1/2/3
 267 c     trifad(4,2) = triangle de la face voisin de F3 et F4 : FF2 + 2/3/1
 268 c     trifad(4,3) = triangle de la face voisin de F5 et F3 : FF2 + 3/1/2
 269 c     areqtr(4,1) : arete de trifad(4,1) : AN5N6
 270 c     areqtr(4,2) : arete de trifad(4,2) : AN4N5
 271 c     areqtr(4,3) : arete de trifad(4,3) : AN4N6
 272 c
 273       if ( codret.eq.0 ) then
 274 c
 275       nulofa(1) = 5
 276       nulofa(2) = 4
 277       nulofa(3) = 3
 278       nulofa(4) = 2
 279 c
 280       tabind(0) = 4
 281       tabind(1) = 3
 282       tabind(2) = 2
 283       tabind(3) = 1
 284 c
 285 #ifdef _DEBUG_HOMARD_
 286       write (ulsort,texte(langue,3)) 'CMCP5B', nompro
 287 #endif
 288       call cmcp5b ( nulofa, lepent,
 289      >              i2, i3, i1, tabind,
 290      >              somare,
 291      >              aretri, nivtri, filtri,
 292      >              filqua,
 293      >              facpen, cofape,
 294      >              niveau,
 295      >              trifad, cotrvo, areqtr,
 296      >              ulsort, langue, codret )
 297 c
 298       endif
 299 c
 300 c====
 301 c 3. Creation du noeud interne
 302 c 4. Creation des aretes internes
 303 c    areint(1) : AS2N0
 304 c    areint(2) : AS1N0
 305 c    areint(3) : AS3N0
 306 c    areint(4) : AN6N0
 307 c    areint(5) : AN5N0
 308 c    areint(6) : AN4N0
 309 c====
 310 #ifdef _DEBUG_HOMARD_
 311       write (ulsort,98000) indnoe+1, indnoe+1
 312       write (ulsort,91000) indare+1, indare+6
 313 #endif
 314 c
 315       if ( codret.eq.0 ) then
 316 c
 317 #ifdef _DEBUG_HOMARD_
 318       write (ulsort,texte(langue,3)) 'CMCHPB', nompro
 319 #endif
 320       iaux = 6
 321       call cmchpb ( indnoe, indare, iaux,
 322      >              nbsomm, lesnoe, areint,
 323      >              coonoe, hetnoe, arenoe,
 324      >              famnoe,
 325      >              hetare, somare,
 326      >              filare, merare, famare,
 327      >              ulsort, langue, codret )
 328 c
 329 #ifdef _DEBUG_HOMARD_
 330       do 400 , iaux = indare-5 , indare
 331       write (ulsort,90015) 'Arete', iaux,
 332      >                ', sommets', (somare(jaux,iaux),jaux=1,2)
 333   400 continue
 334 #endif
 335 c
 336       endif
 337 c
 338 c====
 339 c 5. Creation des 15 triangles internes
 340 c      triint( 1) = FS2N56
 341 c      triint( 2) = FS1N45
 342 c      triint( 3) = FS3N46
 343 c      triint( 4) = FN5N6
 344 c      triint( 5) = FN4N5
 345 c      triint( 6) = FN4N6
 346 c      triint( 7) = FA3
 347 c      triint( 8) = FA2
 348 c      triint( 9) = FA1
 349 c      triint(10) = FS3N6
 350 c      triint(11) = FS2N5
 351 c      triint(12) = FS1N4
 352 c      triint(13) = FS2N6
 353 c      triint(14) = FS1N5
 354 c      triint(15) = FS3N4
 355 c====
 356 #ifdef _DEBUG_HOMARD_
 357       write (ulsort,92000) indtri+1, indtri+15
 358 #endif
 359 c
 360       if ( codret.eq.0 ) then
 361 c
 362       lesare(1) = listar(3)
 363       lesare(2) = listar(2)
 364       lesare(3) = listar(1)
 365 c
 366 #ifdef _DEBUG_HOMARD_
 367       write (ulsort,texte(langue,3)) 'CMCP5C', nompro
 368 #endif
 369       call cmcp5c ( indtri, triint,
 370      >              lesare,
 371      >              areint, areqtr, niveau,
 372      >              aretri, famtri, hettri,
 373      >              filtri, pertri, nivtri,
 374      >              ulsort, langue, codret )
 375 c
 376 #ifdef _DEBUG_HOMARD_
 377       do 500 , iaux = indtri-14 , indtri
 378         write(ulsort,90015) 'tria', iaux,
 379      >                      ' : aretes =', (aretri(iaux,jaux),jaux=1,3)
 380   500 continue
 381 #endif
 382 c
 383       endif
 384 c
 385 c====
 386 c 6. Creation de la pyramide
 387 c====
 388 c
 389 c====
 390 c 7. Creation des tetraedres
 391 c====
 392 c
 393 #ifdef _DEBUG_HOMARD_
 394       write (ulsort,93000) indtet+1, indtet+10
 395 #endif
 396 c
 397       if ( codret.eq.0 ) then
 398 c
 399       iaux = 1
 400 c
 401       jaux = per001(6,cf1)
 402 #ifdef _DEBUG_HOMARD_
 403       write (ulsort,texte(langue,3)) 'CMCP5E', nompro
 404 #endif
 405       call cmcp5e ( indtet, indptp,
 406      >              lepent,
 407      >              trifad, cotrvo, triint,
 408      >              iaux, f1, jaux,
 409      >              hettet, tritet, cotrte,
 410      >              filtet, pertet, famtet,
 411      >              fampen, cfapen,
 412      >              ulsort, langue, codret )
 413 c
 414 #ifdef _DEBUG_HOMARD_
 415       do 700 , iaux = indtet-10 , indtet
 416         write (ulsort,90015) 'Tetra', iaux,
 417      >                ', faces', (tritet(iaux,jaux),jaux=1,4)
 418         write(ulsort,90015) 'Tetra', iaux,
 419      >                ', codes', (cotrte(iaux,jaux),jaux=1,4)
 420   700 continue
 421 #endif
 422 c
 423       endif
 424 c
 425 c====
 426 c 8. la fin
 427 c====
 428 c
 429       if ( codret.ne.0 ) then
 430 c
 431 #include "envex2.h"
 432 c
 433       write (ulsort,texte(langue,1)) 'Sortie', nompro
 434       write (ulsort,texte(langue,2)) codret
 435 c
 436       endif
 437 c
 438 #ifdef _DEBUG_HOMARD_
 439       write (ulsort,texte(langue,1)) 'Sortie', nompro
 440       call dmflsh (iaux)
 441 #endif
 442 c
 443       end