src/tool/Creation_Maillage/cmcp22.F

   1       subroutine cmcp22 ( 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 22 - par les aretes 2 et 9
  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 = 'CMCP22' )
  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 f2, cf2
 134 #ifdef _DEBUG_HOMARD_
 135       integer f1, cf1
 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       f2 = facpen(lepent,2)
 178       cf2 = cofape(lepent,2)
 179 #ifdef _DEBUG_HOMARD_
 180       f1 = facpen(lepent,1)
 181       cf1 = cofape(lepent,1)
 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 #ifdef _DEBUG_HOMARD_
 196       write (ulsort,90015) 'Triangle', f2,
 197      >                ', aretes', (aretri(f2,jaux),jaux=1,3)
 198 #endif
 199 c
 200 c 2.2. ==> grandeurs dependant du cas traite
 201 c     iaux = numero local de l'arete coupee
 202 c     jaux = numero global de l'arete coupee
 203 c     noemil = noeud milieu de l'arete coupee
 204 c
 205       iaux = 2
 206       jaux = listar(iaux)
 207       noemil(1) = somare(2,filare(jaux))
 208 c
 209       iaux = 9
 210       jaux = listar(iaux)
 211       noemil(2) = somare(2,filare(jaux))
 212 c
 213 #ifdef _DEBUG_HOMARD_
 214       write(ulsort,90002) 'noemil', noemil
 215 #endif
 216 c
 217 c 2.3. ==> Triangles et aretes tracees sur les faces coupees
 218 c
 219 c     trifad(1,0) = triangle central de la face 1 : FF4
 220 c     trifad(1,1) = triangle de la face 1 du cote de S2 : FF4 + 1/2
 221 c     trifad(1,2) = triangle de la face 1 du cote de S1 : FF4 + 2/1
 222 c     areqtr(1,1) : AS5N2
 223 c     areqtr(1,2) : AS4N2
 224 c
 225 c     trifad(2,0) = triangle central de la face 2 : FF5
 226 c     trifad(2,1) = triangle de la face 2 du cote de F1 : FF5 + 1/2
 227 c     trifad(2,2) = triangle de la face 2 du cote de F2 : FF5 + 2/1
 228 c     areqtr(2,1) : AS2N9
 229 c     areqtr(2,2) : AS5N9
 230 c
 231 c     trifad(3,0) = triangle central de la face 3 : FF3
 232 c     trifad(3,1) = triangle de la face 3 du cote de F1 : FF3 + 1/2
 233 c     trifad(3,2) = triangle de la face 3 du cote de F2 : FF3 + 2/1
 234 c     areqtr(3,1) : AS1N9
 235 c     areqtr(3,2) : AS4N9
 236 c
 237 c     trifad(4,0) = triangle 1 de la face 4 : FF1 + 0/1 (FF1D3)
 238 c     trifad(4,1) = triangle 2 de la face 4 : FF1 + 1/0 (FF1D1)
 239 c     areqtr(4,1) : AS3N2
 240 c
 241 c     areqtr(1,0) : AS2N2
 242 c     areqtr(2,0) : AS1N2
 243 c     areqtr(3,0) : AS3N9
 244 c
 245       if ( codret.eq.0 ) then
 246 c
 247       nulofa(1) = 4
 248       nulofa(2) = 5
 249       nulofa(3) = 3
 250       nulofa(4) = 1
 251 c
 252       iaux = 4
 253 c
 254 #ifdef _DEBUG_HOMARD_
 255       write (ulsort,texte(langue,3)) 'CMCP2B', nompro
 256 #endif
 257       call cmcp2b ( nulofa, lepent,
 258      >              i2, i3, i1, iaux,
 259      >              aretri, nivtri, filtri,
 260      >              filqua,
 261      >              facpen, cofape,
 262      >              niveau,
 263      >              trifad, cotrvo, areqtr,
 264      >              ulsort, langue, codret )
 265 c
 266       endif
 267 c
 268 c====
 269 c 3. Creation du noeud interne
 270 c====
 271 c====
 272 c 4. Creation de l'arete interne
 273 c    noemil(1) : N2
 274 c    noemil(2) : N9
 275 c    areint(1) : AN2N9
 276 c====
 277 #ifdef _DEBUG_HOMARD_
 278       write (ulsort,91000) indare+1, indare+1
 279 #endif
 280 c
 281       if ( codret.eq.0 ) then
 282 c
 283       indare = indare + 1
 284       areint(1) = indare
 285 c
 286       somare(1,areint(1)) = min ( noemil(1) , noemil(2) )
 287       somare(2,areint(1)) = max ( noemil(1) , noemil(2) )
 288 c
 289       famare(areint(1)) = 1
 290       hetare(areint(1)) = 50
 291       merare(areint(1)) = 0
 292       filare(areint(1)) = 0
 293 #ifdef _DEBUG_HOMARD_
 294       write(ulsort,90006) 'areint(1) = ', areint(1),
 295      >                   ' de ',somare(1,areint(1)),
 296      >                   ' a ',somare(2,areint(1))
 297 #endif
 298 c
 299       endif
 300 c====
 301 c 5. Creation des six triangles internes
 302 c    triint(1) : FA5
 303 c    triint(2) : FS5
 304 c    triint(3) : FS4
 305 c    triint(4) : FS2
 306 c    triint(5) : FS1
 307 c    triint(6) : FS3
 308 c====
 309 c
 310 #ifdef _DEBUG_HOMARD_
 311       write (ulsort,92000) indtri+1, indtri+6
 312 #endif
 313 c
 314       if ( codret.eq.0 ) then
 315 c
 316       lesare(1) = listar(5)
 317 c
 318 #ifdef _DEBUG_HOMARD_
 319       write (ulsort,texte(langue,3)) 'CMCP2C', nompro
 320 #endif
 321       call cmcp2c ( indtri, triint,
 322      >              lesare,
 323      >              areint, areqtr, niveau,
 324      >              aretri, famtri, hettri,
 325      >              filtri, pertri, nivtri,
 326      >              ulsort, langue, codret )
 327 c
 328       endif
 329 c
 330 #ifdef _DEBUG_HOMARD_
 331       do 500 , iaux = indtri-5 , indtri
 332       write (ulsort,90015) 'Triangle', iaux,
 333      >                ', aretes', (aretri(iaux,jaux),jaux=1,3)
 334   500 continue
 335 #endif
 336 c
 337 c====
 338 c 6. Creation de la pyramide
 339 c====
 340 c
 341 c====
 342 c 7. Creation des 6 tetraedres
 343 c====
 344 c
 345 #ifdef _DEBUG_HOMARD_
 346       write (ulsort,93000) indtet+1, indtet+6
 347 #endif
 348 c
 349       if ( codret.eq.0 ) then
 350 c
 351       coface = per001(6,cf2)
 352 c
 353 #ifdef _DEBUG_HOMARD_
 354       write (ulsort,texte(langue,3)) 'CMCP2E', nompro
 355 #endif
 356       call cmcp2e ( indtet, indptp,
 357      >              lepent,
 358      >              trifad, cotrvo, triint,
 359      >              f2, coface,
 360      >              hettet, tritet, cotrte,
 361      >              filtet, pertet, famtet,
 362      >              fampen, cfapen,
 363      >              ulsort, langue, codret )
 364 c
 365 #ifdef _DEBUG_HOMARD_
 366       do 700 , iaux = indtet-5 , indtet
 367         write (ulsort,90015) 'Tetra', iaux,
 368      >                ', faces', (tritet(iaux,jaux),jaux=1,4)
 369         write(ulsort,90015) 'Tetra', iaux,
 370      >                ', codes', (cotrte(iaux,jaux),jaux=1,4)
 371   700 continue
 372 #endif
 373 c
 374       endif
 375 c
 376 c====
 377 c 8. la fin
 378 c====
 379 c
 380       if ( codret.ne.0 ) then
 381 c
 382 #include "envex2.h"
 383 c
 384       write (ulsort,texte(langue,1)) 'Sortie', nompro
 385       write (ulsort,texte(langue,2)) codret
 386 c
 387       endif
 388 c
 389 #ifdef _DEBUG_HOMARD_
 390       write (ulsort,texte(langue,1)) 'Sortie', nompro
 391       call dmflsh (iaux)
 392 #endif
 393 c
 394       end