src/tool/Creation_Maillage/cmcp3f.F

   1       subroutine cmcp3f ( nulofa, lepent,
   2      >                    ind11, ind12, ind13,
   3      >                    ind21, ind22, ind23,
   4      >                    ind001,
   5      >                    somare,
   6      >                    aretri, nivtri, filtri,
   7      >                    filqua,
   8      >                    facpen, cofape,
   9      >                    niveau,
  10      >                    trifad, cotrvo, areqtr,
  11      >                    ulsort, langue, codret )
  12 c
  13 c ______________________________________________________________________
  14 c
  15 c                             H O M A R D
  16 c
  17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  18 c
  19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  20 c aupres des huissiers de justice Simart et Lavoir a Clamart
  21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  22 c aupres des huissiers de justice
  23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  24 c
  25 c    HOMARD est une marque deposee d'Electricite de France
  26 c
  27 c Copyright EDF 1996
  28 c Copyright EDF 1998
  29 c Copyright EDF 2002
  30 c Copyright EDF 2020
  31 c ______________________________________________________________________
  32 c
  33 c    Creation du Maillage - Conformite - decoupage des Pentaedres
  34 c    -           -          -                          -
  35 c                         - cas 3, phase F
  36 c                               -        -
  37 c    Reperage des aretes et des triangles sur les faces externes
  38 c    Remarque : cmcp3b et cmcp3f sont des clones
  39 c ______________________________________________________________________
  40 c .        .     .        .                                            .
  41 c .  nom   . e/s . taille .           description                      .
  42 c .____________________________________________________________________.
  43 c . nulofa . e   .   4    . numero local des faces a traiter           .
  44 c . lepent . e   .   1    . pentaedre a decouper                       .
  45 c . indi1  . e   .   1    . i1i2i3 associe a l'arete coupee face i     .
  46 c . indi2  . e   .   1    . i1i2i3 associe a l'arete du cote de pyra   .
  47 c . indi3  . e   .   1    . i1i2i3 associe a l'arete oppose a la pyra  .
  48 c . ind001 . e   .   4    . redirection dans per001                    .
  49 c . somare . e   .2*nouvar. numeros des extremites d'arete             .
  50 c . aretri . e   .nouvtr*3. numeros des 3 aretes des triangles         .
  51 c . nivtri . e   . nouvtr . niveau des triangles                       .
  52 c . filtri . e   . nouvtr . premier fils des triangles                 .
  53 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  54 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  55 c . cofape . e   .nouvpf*5. codes des faces des pentaedres             .
  56 c . niveau .  s  .   1    . niveau des faces issus du decoupage        .
  57 c . trifad .  s  .(4,0:2) . triangles traces sur les faces decoupees   .
  58 c . cotrvo .  s  .(4,0:2) . code des triangles dans les volumes        .
  59 c . areqtr .  s  .(4,0:2) . aretes tri tracees sur les faces decoupees .
  60 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  61 c . langue . e   .    1   . langue des messages                        .
  62 c .        .     .        . 1 : francais, 2 : anglais                  .
  63 c . codret . es  .    1   . code de retour des modules                 .
  64 c .        .     .        . 0 : pas de probleme                        .
  65 c .        .     .        . 1 : aucune arete ne correspond             .
  66 c ______________________________________________________________________
  67 c
  68 c====
  69 c 0. declarations et dimensionnement
  70 c====
  71 c
  72 c 0.1. ==> generalites
  73 c
  74       implicit none
  75       save
  76 c
  77       character*6 nompro
  78       parameter ( nompro = 'CMCP3F' )
  79 c
  80 #include "nblang.h"
  81 c
  82 c 0.2. ==> communs
  83 c
  84 #include "envex1.h"
  85 c
  86 #include "nouvnb.h"
  87 #include "ope001.h"
  88 #include "demitr.h"
  89 c
  90 c 0.3. ==> arguments
  91 c
  92       integer lepent, nulofa(4)
  93       integer ind11(6), ind12(6), ind13(6)
  94       integer ind21(6), ind22(6), ind23(6)
  95       integer ind001(4)
  96       integer somare(2,nouvar)
  97       integer aretri(nouvtr,3), nivtri(nouvtr), filtri(nouvtr)
  98       integer filqua(nouvqu)
  99       integer facpen(nouvpf,5), cofape(nouvpf,5)
 100       integer niveau
 101       integer areqtr(4,0:2)
 102       integer trifad(4,0:2), cotrvo(4,0:2)
 103 c
 104       integer ulsort, langue, codret
 105 c
 106 c 0.4. ==> variables locales
 107 c
 108       integer iaux, jaux
 109 c
 110       integer nbmess
 111       parameter ( nbmess = 10 )
 112       character*80 texte(nblang,nbmess)
 113 c
 114 c 0.5. ==> initialisations
 115 c ______________________________________________________________________
 116 c
 117 c====
 118 c 1. initialisations
 119 c====
 120 c
 121 #include "impr01.h"
 122 c
 123 #ifdef _DEBUG_HOMARD_
 124       write (ulsort,texte(langue,1)) 'Entree', nompro
 125       call dmflsh (iaux)
 126 #endif
 127 c
 128 #include "impr03.h"
 129 #include "impr04.h"
 130 c
 131       codret = 0
 132 c
 133 c====
 134 c 2. Triangles et aretes tracees sur les quadrangles coupees en 3
 135 c     On traite les faces du pentaedre coupees en 3 comme suit :
 136 c       La 1ere face est celle qui contient l'arete de F1 coupee.
 137 c     trifad(p,0) : triangle central de ce decoupage
 138 c     trifad(p,1) : triangle bordant l'arete non decoupee qui
 139 c                   appartient a la pyramide
 140 c     trifad(p,2) : triangle bordant l'arete non decoupee qui
 141 c                   n'appartient pas a la pyramide
 142 c     areqtr(p,1) : arete interne au quadrangle de bord et bordant le
 143 c                   triangle trifad(p,1)
 144 c     areqtr(p,2) : arete interne au quadrangle de bord et bordant le
 145 c                   triangle trifad(p,2)
 146 c     areqtr(3/4,0) = fille de l'arete coupee, du cote de la pyramide
 147 c     areqtr(3/4,1) = autre fille
 148 c====
 149 c
 150 c 2.1. ==> Face 1
 151 c
 152       iaux = facpen(lepent,nulofa(1))
 153       jaux = cofape(lepent,nulofa(1))
 154       trifad(1,0) = -filqua(iaux)
 155       if ( jaux.lt.5 ) then
 156         cotrvo(1,0) = 4
 157         trifad(1,1) = trifad(1,0) + 2
 158         cotrvo(1,1) = 6
 159         trifad(1,2) = trifad(1,0) + 1
 160         cotrvo(1,2) = 4
 161         areqtr(1,1) = aretri(trifad(1,0),3)
 162         areqtr(1,2) = aretri(trifad(1,0),1)
 163       else
 164         cotrvo(1,0) = 2
 165         trifad(1,1) = trifad(1,0) + 1
 166         cotrvo(1,1) = 2
 167         trifad(1,2) = trifad(1,0) + 2
 168         cotrvo(1,2) = 1
 169         areqtr(1,1) = aretri(trifad(1,0),1)
 170         areqtr(1,2) = aretri(trifad(1,0),3)
 171       endif
 172       areqtr(3,0) = aretri(trifad(1,1),1)
 173       areqtr(3,1) = aretri(trifad(1,2),1)
 174 #ifdef _DEBUG_HOMARD_
 175       write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux
 176       do 2221 , iaux = 0, 2
 177       write (ulsort,90015) 'trifad(1,0/1/2) =', trifad(1,iaux),
 178      >             ', aretes', (aretri(trifad(1,iaux),jaux),jaux=1,3)
 179  2221 continue
 180       write(ulsort,90006) 'cotrvo(1,0) = ', cotrvo(1,0),
 181      >                    'cotrvo(1,1) = ', cotrvo(1,1),
 182      >                    'cotrvo(1,2) = ', cotrvo(1,2)
 183       write(ulsort,90006) 'areqtr(1,1) = ', areqtr(1,1),
 184      >                    ' de ',somare(1,areqtr(1,1)),
 185      >                    ' a ',somare(2,areqtr(1,1))
 186       write(ulsort,90006) 'areqtr(1,2) = ', areqtr(1,2),
 187      >                    ' de ',somare(1,areqtr(1,2)),
 188      >                    ' a ',somare(2,areqtr(1,2))
 189       write(ulsort,90006) 'areqtr(3,0) = ', areqtr(3,0),
 190      >                    ' de ',somare(1,areqtr(3,0)),
 191      >                    ' a ',somare(2,areqtr(3,0))
 192       write(ulsort,90006) 'areqtr(3,1) = ', areqtr(3,1),
 193      >                    ' de ',somare(1,areqtr(3,1)),
 194      >                    ' a ',somare(2,areqtr(3,1))
 195 #endif
 196 c
 197 c 2.2. ==> Face 2
 198 c
 199       iaux = facpen(lepent,nulofa(2))
 200       jaux = cofape(lepent,nulofa(2))
 201       trifad(2,0) = -filqua(iaux)
 202       if ( jaux.lt.5 ) then
 203         cotrvo(2,0) = 4
 204         trifad(2,1) = trifad(2,0) + 2
 205         cotrvo(2,1) = 6
 206         trifad(2,2) = trifad(2,0) + 1
 207         cotrvo(2,2) = 4
 208         areqtr(2,1) = aretri(trifad(2,0),3)
 209         areqtr(2,2) = aretri(trifad(2,0),1)
 210       else
 211         cotrvo(2,0) = 2
 212         trifad(2,1) = trifad(2,0) + 1
 213         cotrvo(2,1) = 2
 214         trifad(2,2) = trifad(2,0) + 2
 215         cotrvo(2,2) = 1
 216         areqtr(2,1) = aretri(trifad(2,0),1)
 217         areqtr(2,2) = aretri(trifad(2,0),3)
 218       endif
 219       areqtr(4,0) = aretri(trifad(2,1),1)
 220       areqtr(4,1) = aretri(trifad(2,2),1)
 221 #ifdef _DEBUG_HOMARD_
 222       write(ulsort,90006) 'Quadrangle = ', iaux,', code =', jaux
 223       do 2222 , iaux = 0, 2
 224       write (ulsort,90015) 'trifad(2,0/1/2) =', trifad(2,iaux),
 225      >             ', aretes', (aretri(trifad(2,iaux),jaux),jaux=1,3)
 226  2222 continue
 227       write(ulsort,90006) 'cotrvo(2,0) = ', cotrvo(2,0),
 228      >                   'cotrvo(2,1) = ', cotrvo(2,1),
 229      >                   'cotrvo(2,2) = ', cotrvo(2,2)
 230       write(ulsort,90006) 'areqtr(2,1) = ', areqtr(2,1),
 231      >                   ' de ',somare(1,areqtr(2,1)),
 232      >                   ' a ',somare(2,areqtr(2,1))
 233       write(ulsort,90006) 'areqtr(2,2) = ', areqtr(2,2),
 234      >                   ' de ',somare(1,areqtr(2,2)),
 235      >                   ' a ',somare(2,areqtr(2,2))
 236       write(ulsort,90006) 'areqtr(4,0) = ', areqtr(4,0),
 237      >                    ' de ',somare(1,areqtr(4,0)),
 238      >                    ' a ',somare(2,areqtr(4,0))
 239       write(ulsort,90006) 'areqtr(4,1) = ', areqtr(4,1),
 240      >                    ' de ',somare(1,areqtr(4,1)),
 241      >                    ' a ',somare(2,areqtr(4,1))
 242 #endif
 243 c
 244 c====
 245 c 3. Triangles et aretes tracees sur les triangles coupes en 2
 246 c     On traite les faces du pentaedre coupees en 3 comme suit :
 247 c       La 1ere face est F1.
 248 c     trifad(p,0) : triangle bordant la pyramide
 249 c     trifad(p,1) : triangle autre
 250 c     areqtr(p,2) : arete commune aux deux triangles fils
 251 c====
 252 c 3.1. ==> Face 3
 253 c
 254       iaux = facpen(lepent,nulofa(3))
 255       jaux = cofape(lepent,nulofa(3))
 256       trifad(3,0) = filtri(iaux) + nutrde(ind11(jaux),ind12(jaux))
 257       trifad(3,1) = filtri(iaux) + nutrde(ind11(jaux),ind13(jaux))
 258       areqtr(3,2) = aretri(trifad(3,0),ind13(jaux))
 259 c
 260       cotrvo(3,0) = per001(ind001(1),jaux)
 261       cotrvo(3,1) = per001(ind001(2),jaux)
 262 #ifdef _DEBUG_HOMARD_
 263       write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux
 264       do 3331 , iaux = 0, 1
 265       write (ulsort,90015) 'trifad(3,0/1) =', trifad(3,iaux),
 266      >             ', aretes', (aretri(trifad(3,iaux),jaux),jaux=1,3)
 267  3331 continue
 268       write(ulsort,90006) 'cotrvo(3,0) = ', cotrvo(3,0),
 269      >                    'cotrvo(3,1) = ', cotrvo(3,1)
 270       write(ulsort,90006) 'areqtr(3,2) = ', areqtr(3,2),
 271      >                    ' de ',somare(1,areqtr(3,2)),
 272      >                    ' a ',somare(2,areqtr(3,2))
 273 #endif
 274 c
 275 c 3.2. ==> Face 4
 276 c
 277       iaux = facpen(lepent,nulofa(4))
 278       jaux = cofape(lepent,nulofa(4))
 279       trifad(4,0) = filtri(iaux) + nutrde(ind21(jaux),ind22(jaux))
 280       trifad(4,1) = filtri(iaux) + nutrde(ind21(jaux),ind23(jaux))
 281       areqtr(4,2) = aretri(trifad(4,0),ind23(jaux))
 282
 283       cotrvo(4,0) = per001(ind001(3),jaux)
 284       cotrvo(4,1) = per001(ind001(4),jaux)
 285 #ifdef _DEBUG_HOMARD_
 286       write(ulsort,90006) 'Triangle = ', iaux,', code =', jaux
 287       do 3332 , iaux = 0, 1
 288       write (ulsort,90015) 'trifad(4,0/1) =', trifad(4,iaux),
 289      >             ', aretes', (aretri(trifad(4,iaux),jaux),jaux=1,3)
 290  3332 continue
 291       write(ulsort,90006) 'cotrvo(4,0) = ', cotrvo(4,0),
 292      >                    'cotrvo(4,1) = ', cotrvo(4,1)
 293       write(ulsort,90006) 'areqtr(4,2) = ', areqtr(4,2),
 294      >                    ' de ',somare(1,areqtr(4,2)),
 295      >                    ' a ',somare(2,areqtr(4,2))
 296 #endif
 297 c
 298 c====
 299 c 4. niveau des triangles des conformites des faces
 300 c====
 301 c
 302       niveau = nivtri(trifad(1,0))
 303 #ifdef _DEBUG_HOMARD_
 304       write(ulsort,90002) 'niveau', niveau
 305 #endif
 306 c
 307 c====
 308 c 5. la fin
 309 c====
 310 c
 311       if ( codret.ne.0 ) then
 312 c
 313 #include "envex2.h"
 314 c
 315       write (ulsort,texte(langue,1)) 'Sortie', nompro
 316       write (ulsort,texte(langue,2)) codret
 317 c
 318       endif
 319 c
 320 #ifdef _DEBUG_HOMARD_
 321       write (ulsort,texte(langue,1)) 'Sortie', nompro
 322       call dmflsh (iaux)
 323 #endif
 324 c
 325       end