src/tool/Creation_Maillage/cmcp26.F

   1       subroutine cmcp26 ( lepent, listar,
   2      >                    indare, indtri, indtet,
   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      >                    facpen, cofape,
  13      >                    fampen, cfapen,
  14      >                    ulsort, langue, codret )
  15 c ______________________________________________________________________
  16 c
  17 c                             H O M A R D
  18 c
  19 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  20 c
  21 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  22 c aupres des huissiers de justice Simart et Lavoir a Clamart
  23 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  24 c aupres des huissiers de justice
  25 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  26 c
  27 c    HOMARD est une marque deposee d'Electricite de France
  28 c
  29 c Copyright EDF 1996
  30 c Copyright EDF 1998
  31 c Copyright EDF 2002
  32 c Copyright EDF 2020
  33 c ______________________________________________________________________
  34 c
  35 c    Creation du Maillage - Conformite - decoupage des Pentaedres
  36 c    -           -          -                          -
  37 c                         - etat 26 - par les aretes 6 et 7
  38 c                                --
  39 c ______________________________________________________________________
  40 c .        .     .        .                                            .
  41 c .  nom   . e/s . taille .           description                      .
  42 c .____________________________________________________________________.
  43 c . lepent . e   .   1    . pentaedre a decouper                       .
  44 c . listar . e   .   9   . liste des aretes du pentaedre a decouper    .
  45 c . indare . es  .   1    . indice de la derniere arete creee          .
  46 c . indtri . es  .   1    . indice du dernier triangle cree            .
  47 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  48 c . indptp . e   .   1    . indice du dernier pere enregistre          .
  49 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  50 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  51 c . filare . es  . nouvar . premiere fille des aretes                  .
  52 c . merare . es  . nouvar . mere des aretes                            .
  53 c . famare .     . nouvar . famille des aretes                         .
  54 c . hettri . es  . nouvtr . historique de l'etat des triangles         .
  55 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  56 c . filtri . es  . nouvtr . premier fils des triangles                 .
  57 c . pertri . es  . nouvtr . pere des triangles                         .
  58 c . famtri . es  . nouvtr . famille des triangles                      .
  59 c . nivtri . es  . nouvtr . niveau des triangles                       .
  60 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  61 c . hettet . es  . nouvte . historique de l'etat des tetraedres        .
  62 c . tritet . es  .nouvtf*4. numeros des 4 triangles des tetraedres     .
  63 c . cotrte . e   .nouvtf*4. code des 4 triangles des tetraedres        .
  64 c . filtet . es  . nouvte . premier fils des tetraedres                .
  65 c . pertet . es  . nouvte . pere des tetraedres                        .
  66 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  67 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  68 c . famtet . es  . nouvte . famille des tetraedres                     .
  69 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  70 c . cofape . e   .nouvpf*5. codes des faces des pentaedres             .
  71 c . fampen . e   . nouvpe . famille des penaedres                      .
  72 c . cfapen . e   . nctfpe*. codes des familles des pentaedres          .
  73 c .        .     . nbfpen .   1 : famille MED                          .
  74 c .        .     .        .   2 : type de pentaedres                   .
  75 c .        .     .        .   3 : famille des tetraedres de conformite .
  76 c .        .     .        .   4 : famille des pyramides de conformite  .
  77 c .        .     .        .   3 : famille des tetraedres de conformite .
  78 c .        .     .        .   4 : famille des pyramides de conformite  .
  79 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  80 c . langue . e   .    1   . langue des messages                        .
  81 c .        .     .        . 1 : francais, 2 : anglais                  .
  82 c . codret . es  .    1   . code de retour des modules                 .
  83 c .        .     .        . 0 : pas de probleme                        .
  84 c .        .     .        . 1 : aucune face ne correspond              .
  85 c ______________________________________________________________________
  86 c
  87 c====
  88 c 0. declarations et dimensionnement
  89 c====
  90 c
  91 c 0.1. ==> generalites
  92 c
  93       implicit none
  94       save
  95 c
  96       character*6 nompro
  97       parameter ( nompro = 'CMCP26' )
  98 c
  99 #include "nblang.h"
 100 c
 101 c 0.2. ==> communs
 102 c
 103 #include "envex1.h"
 104 c
 105 #include "dicfen.h"
 106 #include "nbfami.h"
 107 #include "nouvnb.h"
 108 #include "ope001.h"
 109 #include "i1i2i3.h"
 110 c
 111 c 0.3. ==> arguments
 112 c
 113       integer lepent
 114       integer listar(9)
 115       integer indare, indtri, indtet
 116       integer indptp
 117       integer hetare(nouvar), somare(2,nouvar)
 118       integer filare(nouvar), merare(nouvar), famare(nouvar)
 119       integer hettri(nouvtr), aretri(nouvtr,3)
 120       integer filtri(nouvtr), pertri(nouvtr), famtri(nouvtr)
 121       integer nivtri(nouvtr)
 122       integer filqua(nouvqu)
 123       integer hettet(nouvte), tritet(nouvtf,4), cotrte(nouvtf,4)
 124       integer filtet(nouvte), pertet(nouvte), famtet(nouvte)
 125       integer facpen(nouvpf,5), cofape(nouvpf,5)
 126       integer fampen(nouvpe), cfapen(nctfpe,nbfpen)
 127 c
 128       integer ulsort, langue, codret
 129 c
 130 c 0.4. ==> variables locales
 131 c
 132       integer iaux, jaux
 133       integer f1, cf1
 134 #ifdef _DEBUG_HOMARD_
 135       integer f2, cf2
 136       integer f3, cf3
 137       integer f4, cf4
 138       integer f5, cf5
 139 #endif
 140       integer noemil(2), lesare(1)
 141       integer areint(1)
 142       integer triint(6)
 143       integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2)
 144       integer nulofa(4)
 145       integer niveau
 146       integer coface
 147 c
 148       integer nbmess
 149       parameter ( nbmess = 10 )
 150       character*80 texte(nblang,nbmess)
 151 c
 152 c 0.5. ==> initialisations
 153 c ______________________________________________________________________
 154 c
 155 c====
 156 c 1. messages
 157 c====
 158 c
 159 #include "impr01.h"
 160 c
 161 #ifdef _DEBUG_HOMARD_
 162       write (ulsort,texte(langue,1)) 'Entree', nompro
 163       call dmflsh (iaux)
 164 #endif
 165 c
 166 #include "impr03.h"
 167 #include "impr04.h"
 168 c
 169       codret = 0
 170 c
 171 c====
 172 c 2. initialisations
 173 c====
 174 c 2.1. ==> grandeurs independantes du cas traite (phase 1)
 175 c          les faces du pentaedre et leurs codes
 176 c
 177       f1 = facpen(lepent,1)
 178       cf1 = cofape(lepent,1)
 179 #ifdef _DEBUG_HOMARD_
 180       f2 = facpen(lepent,2)
 181       cf2 = cofape(lepent,2)
 182       f3 = facpen(lepent,3)
 183       cf3 = cofape(lepent,3)
 184       f4 = facpen(lepent,4)
 185       cf4 = cofape(lepent,4)
 186       f5 = facpen(lepent,5)
 187       cf5 = cofape(lepent,5)
 188       write(ulsort,90002) 'f1', f1, cf1
 189       write(ulsort,90002) 'f2', f2, cf2
 190       write(ulsort,90002) 'f3', f3, cf3
 191       write(ulsort,90002) 'f4', f4, cf4
 192       write(ulsort,90002) 'f5', f5, cf5
 193 #endif
 194 c
 195 c 2.2. ==> grandeurs dependant du cas traite
 196 c     iaux = numero local de l'arete coupee
 197 c     jaux = numero global de l'arete coupee
 198 c     noemil = noeud milieu de l'arete coupee
 199 c
 200       iaux = 6
 201       jaux = listar(iaux)
 202       noemil(1) = somare(2,filare(jaux))
 203 c
 204       iaux = 7
 205       jaux = listar(iaux)
 206       noemil(2) = somare(2,filare(jaux))
 207 c
 208 #ifdef _DEBUG_HOMARD_
 209       write(ulsort,90002) 'noemil', noemil
 210 #endif
 211 c
 212 c 2.3. ==> Triangles et aretes tracees sur les faces coupees
 213 c
 214 c     trifad(1,0) = triangle central de la face 1 : FF5
 215 c     trifad(1,1) = triangle de la face 1 du cote de S5 : FF5 + 1/2
 216 c     trifad(1,2) = triangle de la face 1 du cote de S6 : FF5 + 2/1
 217 c     areqtr(1,1) : AS2N6
 218 c     areqtr(1,2) : AS3N6
 219 c
 220 c     trifad(2,0) = triangle central de la face 2 : FF4
 221 c     trifad(2,1) = triangle de la face 2 du cote de F2 : FF4 + 1/2
 222 c     trifad(2,2) = triangle de la face 2 du cote de F1 : FF4 + 2/1
 223 c     areqtr(2,1) : AS5N7
 224 c     areqtr(2,2) : AS2N7
 225 c
 226 c     trifad(3,0) = triangle central de la face 3 : FF3
 227 c     trifad(3,1) = triangle de la face 3 du cote de F2 : FF3 + 1/2
 228 c     trifad(3,2) = triangle de la face 3 du cote de F1 : FF3 + 2/1
 229 c     areqtr(3,1) : AS6N7
 230 c     areqtr(3,2) : AS3N7
 231 c
 232 c     trifad(4,0) = triangle 1 de la face 4 : FF2 + 0/1 (FF2D5)
 233 c     trifad(4,1) = triangle 2 de la face 4 : FF2 + 1/0 (FF2D4)
 234 c     areqtr(4,1) : AS4N6
 235 c
 236 c     areqtr(1,0) : AS5N6
 237 c     areqtr(2,0) : AS6N6
 238 c     areqtr(3,0) : AS4N7
 239 c
 240       if ( codret.eq.0 ) then
 241 c
 242       nulofa(1) = 5
 243       nulofa(2) = 4
 244       nulofa(3) = 3
 245       nulofa(4) = 2
 246 c
 247       iaux = 4
 248 c
 249 #ifdef _DEBUG_HOMARD_
 250       write (ulsort,texte(langue,3)) 'CMCP2B', nompro
 251 #endif
 252       call cmcp2b ( nulofa, lepent,
 253      >              i3, i2, i1, iaux,
 254      >              aretri, nivtri, filtri,
 255      >              filqua,
 256      >              facpen, cofape,
 257      >              niveau,
 258      >              trifad, cotrvo, areqtr,
 259      >              ulsort, langue, codret )
 260 c
 261       endif
 262 c
 263 c====
 264 c 3. Creation du noeud interne
 265 c====
 266 c====
 267 c 4. Creation de l'arete interne
 268 c    noemil(1) : N6
 269 c    noemil(2) : N7
 270 c    areint(1) : AN6N7
 271 c====
 272 #ifdef _DEBUG_HOMARD_
 273       write (ulsort,91000) indare+1, indare+1
 274 #endif
 275 c
 276       if ( codret.eq.0 ) then
 277 c
 278       indare = indare + 1
 279       areint(1) = indare
 280 c
 281       somare(1,areint(1)) = min ( noemil(1) , noemil(2) )
 282       somare(2,areint(1)) = max ( noemil(1) , noemil(2) )
 283 c
 284       famare(areint(1)) = 1
 285       hetare(areint(1)) = 50
 286       merare(areint(1)) = 0
 287       filare(areint(1)) = 0
 288 #ifdef _DEBUG_HOMARD_
 289       write(ulsort,90006) 'areint(1) = ', areint(1),
 290      >                   ' de ',somare(1,areint(1)),
 291      >                   ' a ',somare(2,areint(1))
 292 #endif
 293 c
 294       endif
 295 c====
 296 c 5. Creation des six triangles internes
 297 c    triint(1) : FA3
 298 c    triint(2) : FS1
 299 c    triint(3) : FS2
 300 c    triint(4) : FS5
 301 c    triint(5) : FS6
 302 c    triint(6) : FS4
 303 c====
 304 c
 305 #ifdef _DEBUG_HOMARD_
 306       write (ulsort,92000) indtri+1, indtri+6
 307 #endif
 308 c
 309       if ( codret.eq.0 ) then
 310 c
 311       lesare(1) = listar(3)
 312 c
 313 #ifdef _DEBUG_HOMARD_
 314       write (ulsort,texte(langue,3)) 'CMCP2C', nompro
 315 #endif
 316       call cmcp2c ( indtri, triint,
 317      >              lesare,
 318      >              areint, areqtr, niveau,
 319      >              aretri, famtri, hettri,
 320      >              filtri, pertri, nivtri,
 321      >              ulsort, langue, codret )
 322 c
 323 #ifdef _DEBUG_HOMARD_
 324       do 500 , iaux = indtri-5 , indtri
 325       write (ulsort,90015) 'Triangle', iaux,
 326      >                ', aretes', (aretri(iaux,jaux),jaux=1,3)
 327   500 continue
 328 #endif
 329 c
 330       endif
 331 c
 332 c====
 333 c 6. Creation de la pyramide
 334 c====
 335 c
 336 c====
 337 c 7. Creation des 6 tetraedres
 338 c====
 339 c
 340 #ifdef _DEBUG_HOMARD_
 341       write (ulsort,93000) indtet+1, indtet+6
 342 #endif
 343 c
 344       if ( codret.eq.0 ) then
 345 c
 346       coface = per001(6,cf1)
 347 c
 348 #ifdef _DEBUG_HOMARD_
 349       write (ulsort,texte(langue,3)) 'CMCP2E', nompro
 350 #endif
 351       call cmcp2e ( indtet, indptp,
 352      >              lepent,
 353      >              trifad, cotrvo, triint,
 354      >              f1, coface,
 355      >              hettet, tritet, cotrte,
 356      >              filtet, pertet, famtet,
 357      >              fampen, cfapen,
 358      >              ulsort, langue, codret )
 359 c
 360 #ifdef _DEBUG_HOMARD_
 361       do 700 , iaux = indtet-5 , indtet
 362         write (ulsort,90015) 'Tetra', iaux,
 363      >                ', faces', (tritet(iaux,jaux),jaux=1,4)
 364         write(ulsort,90015) 'Tetra', iaux,
 365      >                ', codes', (cotrte(iaux,jaux),jaux=1,4)
 366   700 continue
 367 #endif
 368 c
 369       endif
 370 c
 371 c====
 372 c 8. la fin
 373 c====
 374 c
 375       if ( codret.ne.0 ) then
 376 c
 377 #include "envex2.h"
 378 c
 379       write (ulsort,texte(langue,1)) 'Sortie', nompro
 380       write (ulsort,texte(langue,2)) codret
 381 c
 382       endif
 383 c
 384 #ifdef _DEBUG_HOMARD_
 385       write (ulsort,texte(langue,1)) 'Sortie', nompro
 386       call dmflsh (iaux)
 387 #endif
 388 c
 389       end