src/tool/Creation_Maillage/cmcp4b.F

   1       subroutine cmcp4b ( nulofa, lepent,
   2      >                    ind11, ind12, ind13,
   3      >                    ind21, ind22, ind23,
   4      >                    tabind,
   5      >                    somare,
   6      >                    aretri, nivtri, filtri,
   7      >                    arequa, filqua,
   8      >                    facpen, cofape,
   9      >                    noemil,
  10      >                    niveau,
  11      >                    trifad, cotrvo, areqtr,
  12      >                    quafad, areqqu,
  13      >                    ulsort, langue, codret )
  14 c
  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                         - cas 4, phase B
  38 c                               -        -
  39 c    Reperage des aretes, triangles, quadrangles sur les faces externes
  40 c ______________________________________________________________________
  41 c .        .     .        .                                            .
  42 c .  nom   . e/s . taille .           description                      .
  43 c .____________________________________________________________________.
  44 c . nulofa . e   .   5    . numero local des faces a traiter           .
  45 c . lepent . e   .   1    . pentaedre a decouper                       .
  46 c . indi1  . e   .   1    . i1i2i3 associe a l'arete coupee face i     .
  47 c . indi2  . e   .   1    . i1i2i3 associe a l'arete suivante          .
  48 c . indi3  . e   .   1    . i1i2i3 associe a l'arete precedente        .
  49 c . tabind . e   .   4    . redirection dans per001                    .
  50 c . somare . e   .2*nouvar. numeros des extremites d'arete             .
  51 c . aretri . e   .nouvtr*3. numeros des 3 aretes des triangles         .
  52 c . nivtri . e   . nouvtr . niveau des triangles                       .
  53 c . filtri . e   . nouvtr . premier fils des triangles                 .
  54 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  55 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  56 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  57 c . cofape . e   .nouvpf*5. codes des faces des pentaedres             .
  58 c . noemil .  s  .   1    . noeud milieu de la face quad coupee en 4   .
  59 c . niveau .  s  .   1    . niveau des faces issus du decoupage        .
  60 c . trifad .  s  .(4,0:2) . triangles traces sur les faces decoupees   .
  61 c . cotrvo .  s  .(4,0:2) . code des triangles dans les volumes        .
  62 c . areqtr .  s  .(4,0:2) . aretes tri tracees sur les faces decoupees .
  63 c . quafad .  s  .   4    . quadrangles traces sur les faces decoupees .
  64 c . areqqu .  s  .   4    . aretes qua tracees sur les faces decoupees .
  65 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  66 c . langue . e   .    1   . langue des messages                        .
  67 c .        .     .        . 1 : francais, 2 : anglais                  .
  68 c . codret . es  .    1   . code de retour des modules                 .
  69 c .        .     .        . 0 : pas de probleme                        .
  70 c .        .     .        . 1 : aucune arete ne correspond             .
  71 c ______________________________________________________________________
  72 c
  73 c====
  74 c 0. declarations et dimensionnement
  75 c====
  76 c
  77 c 0.1. ==> generalites
  78 c
  79       implicit none
  80       save
  81 c
  82       character*6 nompro
  83       parameter ( nompro = 'CMCP4B' )
  84 c
  85 #include "nblang.h"
  86 c
  87 c 0.2. ==> communs
  88 c
  89 #include "envex1.h"
  90 c
  91 #include "nouvnb.h"
  92 #include "ope001.h"
  93 #include "demitr.h"
  94 #include "defiqu.h"
  95 c
  96 c 0.3. ==> arguments
  97 c
  98       integer lepent, nulofa(5)
  99       integer ind11(6), ind12(6), ind13(6)
 100       integer ind21(6), ind22(6), ind23(6)
 101       integer tabind(4)
 102       integer somare(2,nouvar)
 103       integer aretri(nouvtr,3), nivtri(nouvtr), filtri(nouvtr)
 104       integer arequa(nouvqu,4)
 105       integer filqua(nouvqu)
 106       integer facpen(nouvpf,5), cofape(nouvpf,5)
 107       integer noemil
 108       integer niveau
 109       integer trifad(4,0:2), cotrvo(4,0:2), areqtr(4,0:2)
 110       integer quafad(4), areqqu(4)
 111 c
 112       integer ulsort, langue, codret
 113 c
 114 c 0.4. ==> variables locales
 115 c
 116       integer iaux, jaux
 117 c
 118       integer nbmess
 119       parameter ( nbmess = 10 )
 120       character*80 texte(nblang,nbmess)
 121 c
 122 c 0.5. ==> initialisations
 123 c ______________________________________________________________________
 124 c
 125 c====
 126 c 1. initialisations
 127 c====
 128 c
 129 #include "impr01.h"
 130 c
 131 #ifdef _DEBUG_HOMARD_
 132       write (ulsort,texte(langue,1)) 'Entree', nompro
 133       call dmflsh (iaux)
 134 #endif
 135 c
 136 #include "impr03.h"
 137 #include "impr04.h"
 138 c
 139       codret = 0
 140 c
 141 c====
 142 c 2. Triangles et aretes tracees sur les quadrangles coupes en 3
 143 c     On traite les faces du pentaedre coupees en 3 comme suit :
 144 c       La 1ere face est celle qui contient l'arete de F1 coupee.
 145 c     trifad(p,0) : triangle central de ce decoupage
 146 c     trifad(p,1) : triangle bordant cette arete non decoupee
 147 c     trifad(p,2) : l'autre triangle
 148 c     areqtr(p,1) : arete interne au quadrangle de bord et bordant le
 149 c                   triangle trifad(p,1)
 150 c     areqtr(p,2) : arete interne au quadrangle de bord et bordant le
 151 c                   triangle trifad(p,2)
 152 c====
 153 c
 154 c 2.1. ==> Face 1
 155 c
 156       iaux = facpen(lepent,nulofa(1))
 157       jaux = cofape(lepent,nulofa(1))
 158       trifad(1,0) = -filqua(iaux)
 159       if ( jaux.lt.5 ) then
 160         cotrvo(1,0) = 4
 161         trifad(1,1) = trifad(1,0) + 2
 162         cotrvo(1,1) = 2
 163         trifad(1,2) = trifad(1,0) + 1
 164         cotrvo(1,2) = 3
 165         areqtr(1,1) = aretri(trifad(1,0),3)
 166         areqtr(1,2) = aretri(trifad(1,0),1)
 167       else
 168         cotrvo(1,0) = 2
 169         trifad(1,1) = trifad(1,0) + 1
 170         cotrvo(1,1) = 6
 171         trifad(1,2) = trifad(1,0) + 2
 172         cotrvo(1,2) = 5
 173         areqtr(1,1) = aretri(trifad(1,0),1)
 174         areqtr(1,2) = aretri(trifad(1,0),3)
 175       endif
 176 #ifdef _DEBUG_HOMARD_
 177       write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux
 178       do 2221 , iaux = 0, 2
 179       write (ulsort,90015) 'trifad(1,0/1/2) =', trifad(1,iaux),
 180      >             ', aretes', (aretri(trifad(1,iaux),jaux),jaux=1,3)
 181  2221 continue
 182       write(ulsort,90006) 'cotrvo(1,0) = ', cotrvo(1,0),
 183      >                    'cotrvo(1,1) = ', cotrvo(1,1),
 184      >                    'cotrvo(1,2) = ', cotrvo(1,2)
 185       write(ulsort,90006) 'areqtr(1,1) = ', areqtr(1,1),
 186      >                    ' de ',somare(1,areqtr(1,1)),
 187      >                    ' a ',somare(2,areqtr(1,1))
 188       write(ulsort,90006) 'areqtr(1,2) = ', areqtr(1,2),
 189      >                    ' de ',somare(1,areqtr(1,2)),
 190      >                    ' a ',somare(2,areqtr(1,2))
 191 #endif
 192 c
 193 c 2.2. ==> Face 2
 194 c
 195       iaux = facpen(lepent,nulofa(2))
 196       jaux = cofape(lepent,nulofa(2))
 197       trifad(2,0) = -filqua(iaux)
 198       if ( jaux.lt.5 ) then
 199         cotrvo(2,0) = 4
 200         trifad(2,1) = trifad(2,0) + 1
 201         cotrvo(2,1) = 3
 202         trifad(2,2) = trifad(2,0) + 2
 203         cotrvo(2,2) = 2
 204         areqtr(2,1) = aretri(trifad(2,0),1)
 205         areqtr(2,2) = aretri(trifad(2,0),3)
 206       else
 207         cotrvo(2,0) = 2
 208         trifad(2,1) = trifad(2,0) + 2
 209         cotrvo(2,1) = 5
 210         trifad(2,2) = trifad(2,0) + 1
 211         cotrvo(2,2) = 6
 212         areqtr(2,1) = aretri(trifad(2,0),3)
 213         areqtr(2,2) = aretri(trifad(2,0),1)
 214       endif
 215 #ifdef _DEBUG_HOMARD_
 216       write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux
 217       do 2222 , iaux = 0, 2
 218       write (ulsort,90015) 'trifad(2,0/1/2) =', trifad(2,iaux),
 219      >             ', aretes', (aretri(trifad(2,iaux),jaux),jaux=1,3)
 220  2222 continue
 221       write(ulsort,90006) 'cotrvo(2,0) = ', cotrvo(2,0),
 222      >                   'cotrvo(2,1) = ', cotrvo(2,1),
 223      >                   'cotrvo(2,2) = ', cotrvo(2,2)
 224       write(ulsort,90006) 'areqtr(2,1) = ', areqtr(2,1),
 225      >                   ' de ',somare(1,areqtr(2,1)),
 226      >                   ' a ',somare(2,areqtr(2,1))
 227       write(ulsort,90006) 'areqtr(2,2) = ', areqtr(2,2),
 228      >                   ' de ',somare(1,areqtr(2,2)),
 229      >                   ' a ',somare(2,areqtr(2,2))
 230 #endif
 231 c
 232 c====
 233 c 3. Triangles et aretes tracees sur les triangles coupes en 2
 234 c     On traite les faces du pentaedre coupees en 3 comme suit :
 235 c       La 1ere face est F1.
 236 c     trifad(p,0) : triangle bordant la pyramide
 237 c     trifad(p,1) : triangle autre
 238 c     areqtr(p,2) : arete commune aux deux triangles fils
 239 c====
 240 c 3.1. ==> Face 3
 241 c
 242       iaux = facpen(lepent,nulofa(3))
 243       jaux = cofape(lepent,nulofa(3))
 244       trifad(3,0) = filtri(iaux) + nutrde(ind11(jaux),ind12(jaux))
 245       trifad(3,1) = filtri(iaux) + nutrde(ind11(jaux),ind13(jaux))
 246       areqtr(3,2) = aretri(trifad(3,0),ind13(jaux))
 247 c
 248       cotrvo(3,0) = per001(tabind(1),jaux)
 249       cotrvo(3,1) = per001(tabind(2),jaux)
 250 #ifdef _DEBUG_HOMARD_
 251       write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux
 252       do 3331 , iaux = 0, 1
 253       write (ulsort,90015) 'trifad(3,0/1) =', trifad(3,iaux),
 254      >             ', aretes', (aretri(trifad(3,iaux),jaux),jaux=1,3)
 255  3331 continue
 256       write(ulsort,90006) 'cotrvo(3,0) = ', cotrvo(3,0),
 257      >                    'cotrvo(3,1) = ', cotrvo(3,1)
 258       write(ulsort,90006) 'areqtr(3,2) = ', areqtr(3,2),
 259      >                    ' de ',somare(1,areqtr(3,2)),
 260      >                    ' a ',somare(2,areqtr(3,2))
 261 #endif
 262 c
 263 c 3.2. ==> Face 4
 264 c
 265       iaux = facpen(lepent,nulofa(4))
 266       jaux = cofape(lepent,nulofa(4))
 267       trifad(4,0) = filtri(iaux) + nutrde(ind21(jaux),ind22(jaux))
 268       trifad(4,1) = filtri(iaux) + nutrde(ind21(jaux),ind23(jaux))
 269       areqtr(4,2) = aretri(trifad(4,0),ind23(jaux))
 270
 271       cotrvo(4,0) = per001(tabind(4),jaux)
 272       cotrvo(4,1) = per001(tabind(3),jaux)
 273 #ifdef _DEBUG_HOMARD_
 274       write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux
 275       do 3332 , iaux = 0, 1
 276       write (ulsort,90015) 'trifad(4,0/1) =', trifad(4,iaux),
 277      >             ', aretes', (aretri(trifad(4,iaux),jaux),jaux=1,3)
 278  3332 continue
 279       write(ulsort,90006) 'cotrvo(4,0) = ', cotrvo(4,0),
 280      >                    'cotrvo(4,1) = ', cotrvo(4,1)
 281       write(ulsort,90006) 'areqtr(4,2) = ', areqtr(4,2),
 282      >                    ' de ',somare(1,areqtr(4,2)),
 283      >                    ' a ',somare(2,areqtr(4,2))
 284 #endif
 285 c
 286 c====
 287 c 4. Quadrangles et aretes tracees sur la face coupee en 4
 288 c     quafad(0) : quadrangle bordant la face 2 et la face 3
 289 c     quafad(i) : quadrangle suivant dans le sens entrant
 290 c                   dans le pentadere
 291 c     areqqu(p) : arete commune a quafad(p) et quafad(p+1)
 292 c====
 293 c
 294       iaux = facpen(lepent,nulofa(5))
 295       jaux = cofape(lepent,nulofa(5))
 296       quafad(1) = filqua(iaux) + defiq1(jaux)
 297       quafad(2) = filqua(iaux) + defiq2(jaux)
 298       quafad(3) = filqua(iaux) + defiq3(jaux)
 299       quafad(4) = filqua(iaux) + defiq4(jaux)
 300 c
 301       if ( jaux.lt.5 ) then
 302         areqqu(1) = arequa(quafad(1),2)
 303         areqqu(2) = arequa(quafad(2),2)
 304         areqqu(3) = arequa(quafad(3),2)
 305         areqqu(4) = arequa(quafad(4),2)
 306       else
 307         areqqu(1) = arequa(quafad(2),2)
 308         areqqu(2) = arequa(quafad(3),2)
 309         areqqu(3) = arequa(quafad(4),2)
 310         areqqu(4) = arequa(quafad(1),2)
 311       endif
 312 c
 313       noemil = somare(2,areqqu(1))
 314 #ifdef _DEBUG_HOMARD_
 315       write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux
 316       do 4441 , iaux = 1 , 4
 317       write (ulsort,90015) 'quafad(1/2/3/4) =', quafad(iaux),
 318      >             ', aretes', (arequa(quafad(iaux),jaux),jaux=1,4)
 319  4441 continue
 320       do 4442 , iaux = 1 , 4
 321       write (ulsort,90006) 'areqqu(1/2/3/4) =', areqqu(iaux),
 322      >                    ' de ',somare(1,areqqu(iaux)),
 323      >                    ' a ',somare(2,areqqu(iaux))
 324  4442 continue
 325       write(ulsort,90002) 'Noeud milieu = ', noemil
 326 #endif
 327 c
 328 c====
 329 c 5. niveau des triangles des conformites des faces
 330 c====
 331 c
 332       niveau = nivtri(trifad(1,0))
 333 #ifdef _DEBUG_HOMARD_
 334       write(ulsort,90002) 'niveau', niveau
 335 #endif
 336 c
 337 c====
 338 c 6. la fin
 339 c====
 340 c
 341       if ( codret.ne.0 ) then
 342 c
 343 #include "envex2.h"
 344 c
 345       write (ulsort,texte(langue,1)) 'Sortie', nompro
 346       write (ulsort,texte(langue,2)) codret
 347 c
 348       endif
 349 c
 350 #ifdef _DEBUG_HOMARD_
 351       write (ulsort,texte(langue,1)) 'Sortie', nompro
 352       call dmflsh (iaux)
 353 #endif
 354 c
 355       end