src/tool/Creation_Maillage/cmchfa.F

   1       subroutine cmchfa ( facdec, cofdec, facnde, cofnde,
   2      >                    niveau, noefac,
   3      >                    quabas, arefad,
   4      >                    trifad, cotrvo, areqtr,
   5      >                    lehexa, nulofa,
   6      >                    somare, aretri, nivtri,
   7      >                    arequa, filqua,
   8      >                    quahex, coquhe,
   9      >                    tabaux,
  10      >                    ulsort, langue, codret )
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c
  31 c    Creation du Maillage - Conformite - decoupage des Hexaedres
  32 c    -           -          -                          -
  33 c                         - par 1 Face - utilitaire A
  34 c                                 -                 -
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . facnde .  s  .   1    . numero global de la face non decoupee      .
  40 c . cofnde .  s  .   1    . code de la face non decoupee dans l'hexa.  .
  41 c . facdec .  s  .   1    . numero global de la face decoupee          .
  42 c . cofdec .  s  .   1    . code de la face decoupee dans l'hexaedre   .
  43 c . niveau .  s  .   1    . niveau des triangle de conformite des faces.
  44 c . noefac .  s  .   1    . noeud central de la face decoupee en 4     .
  45 c . quabas .  s  .   4    . quadrangles fils de la face coupee en 4    .
  46 c .        .     .        . quabas(p) = base de la pyramide fille p    .
  47 c . arefad .  s  .   4    . aretes tracees sur la face coupee en 4     .
  48 c .        .     .        . arefad(p) est l'arete commune aux pyramides.
  49 c .        .     .        . filles numero p et p+1                     .
  50 c . trifad .  s  .(4,0:2) . triangles sur les faces de conformite      .
  51 c .        .     .        . trifad(p,0) : triangle central du decoupage.
  52 c .        .     .        . trifad(p,1) : tria. bordant la pyramide p  .
  53 c .        .     .        . trifad(p,2) : tria. bordant la pyramide p+1.
  54 c . cotrvo .  s  .(4,0:2) . futur codes des triangles trifad dans la   .
  55 c .        .     .        . description des tetraedres                 .
  56 c . areqtr .  s  .  (4,2) . arete interne au quadrangle de bord et     .
  57 c .        .     .        . bordant le triangle trifad(p,i)            .
  58 c . lehexa . e   .   1    . numero global d'hexaedre                   .
  59 c . nulofa . e   .   1    . numero local de la face couppe en 4        .
  60 c . somare . e   .2*nouvar. numeros des extremites d'arete             .
  61 c . aretri . e   .nouvtr*3. numeros des 3 aretes des triangles         .
  62 c . nivtri . e   . nouvtr . niveau des triangles                       .
  63 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  64 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  65 c . quahex . e   .nouvhf*6. numeros des 6 quadrangles des hexaedres    .
  66 c . coquhe . e   .nouvhf*6. codes des 6 quadrangles des hexaedres      .
  67 c . tabaux . e   .    4   . numeros locaux des faces coupees en 3,     .
  68 c .        .     .        . dans l'ordre des pyramides p/p1+1          .
  69 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  70 c . langue . e   .    1   . langue des messages                        .
  71 c .        .     .        . 1 : francais, 2 : anglais                  .
  72 c . codret . es  .    1   . code de retour des modules                 .
  73 c .        .     .        . 0 : pas de probleme                        .
  74 c .        .     .        . 1 : aucune face ne correspond              .
  75 c ______________________________________________________________________
  76 c
  77 c====
  78 c 0. declarations et dimensionnement
  79 c====
  80 c
  81 c 0.1. ==> generalites
  82 c
  83       implicit none
  84       save
  85 c
  86       character*6 nompro
  87       parameter ( nompro = 'CMCHFA' )
  88 c
  89 #include "nblang.h"
  90 c
  91 c 0.2. ==> communs
  92 c
  93 #include "envex1.h"
  94 c
  95 #include "nouvnb.h"
  96 #include "comp07.h"
  97 #include "defiqu.h"
  98 c
  99 c 0.3. ==> arguments
 100 c
 101       integer facdec, cofdec, facnde, cofnde
 102       integer niveau, noefac
 103       integer quabas(4)
 104       integer arefad(4), areqtr(4,2)
 105       integer trifad(4,0:2), cotrvo(4,0:2)
 106       integer lehexa, nulofa
 107       integer somare(2,nouvar)
 108       integer aretri(nouvtr,3), nivtri(nouvtr)
 109       integer arequa(nouvqu,4), filqua(nouvqu)
 110       integer quahex(nouvhf,6), coquhe(nouvhf,6)
 111       integer tabaux(4)
 112 c
 113       integer ulsort, langue, codret
 114 c
 115 c 0.4. ==> variables locales
 116 c
 117       integer iaux, jaux, kaux
 118 c
 119       integer nbmess
 120       parameter ( nbmess = 10 )
 121       character*80 texte(nblang,nbmess)
 122 c
 123 c 0.5. ==> initialisations
 124 c ______________________________________________________________________
 125 c
 126 c====
 127 c 1. messages
 128 c====
 129 c
 130 #include "impr01.h"
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133       write (ulsort,texte(langue,1)) 'Entree', nompro
 134       call dmflsh (iaux)
 135 #endif
 136 c
 137 #ifdef _DEBUG_HOMARD_
 138  1789 format(5(a,i5,', '))
 139  1792 format(2(a,i1,a,i5,', '))
 140 #endif
 141 c
 142       codret = 0
 143 c
 144 c====
 145 c 2. La face coupee en 4 et son code dans l'hexaedre
 146 c    La face non coupee et son code dans l'hexaedre
 147 c====
 148 c
 149       facdec = quahex(lehexa,nulofa)
 150       cofdec = coquhe(lehexa,nulofa)
 151       facnde = quahex(lehexa,coen07(nulofa))
 152       cofnde = coquhe(lehexa,coen07(nulofa))
 153 #ifdef _DEBUG_HOMARD_
 154       write(ulsort,1789) 'facdec = ', facdec, 'cofdec = ', cofdec
 155       write(ulsort,1789) 'facnde = ', facnde, 'cofnde = ', cofnde
 156 #endif
 157 c
 158 c====
 159 c 3. Noeud central de la face coupee en 4
 160 c====
 161 c
 162       iaux = filqua(facdec)
 163       noefac = somare(2,arequa(iaux,2))
 164 #ifdef _DEBUG_HOMARD_
 165       write(ulsort,1789) 'noefac = ', noefac
 166 #endif
 167 c
 168 c====
 169 c 4. Quadrangles fils de la face coupee en 4
 170 c    quabas(p) est la base de la pyramide fille numero p
 171 c    filqua(facdec) + defiqJ(cofdec) : J-eme fils du quadrangle
 172 c    Attention : la regle de numerotation locale des quadrangles quabas
 173 c                est celle des pyramides ; on part du sommet de plus
 174 c                petit numero local et on tourne en entrant dans
 175 c                l'hexaedre. Pour les fils du quadrangle, on part de la
 176 c                plus petite arete locale et on tourne dans le meme sens
 177 c                D'ou l'eventuel decalage selon les faces
 178 c====
 179 c
 180 #ifdef _DEBUG_HOMARD_
 181       write(ulsort,1789) 'defiq1 = ', defiq1(cofdec)
 182       write(ulsort,1789) 'defiq2 = ', defiq2(cofdec)
 183       write(ulsort,1789) 'defiq3 = ', defiq3(cofdec)
 184       write(ulsort,1789) 'defiq4 = ', defiq4(cofdec)
 185 #endif
 186       if ( nulofa.eq.1 .or. nulofa.eq.3 .or. nulofa.eq.6 ) then
 187         quabas(1) = filqua(facdec) + defiq2(cofdec)
 188         quabas(2) = filqua(facdec) + defiq3(cofdec)
 189         quabas(3) = filqua(facdec) + defiq4(cofdec)
 190         quabas(4) = filqua(facdec) + defiq1(cofdec)
 191       else
 192         quabas(1) = filqua(facdec) + defiq1(cofdec)
 193         quabas(2) = filqua(facdec) + defiq2(cofdec)
 194         quabas(3) = filqua(facdec) + defiq3(cofdec)
 195         quabas(4) = filqua(facdec) + defiq4(cofdec)
 196       endif
 197 #ifdef _DEBUG_HOMARD_
 198       write(ulsort,1789) 'Fils aine = ', filqua(facdec)
 199       write(ulsort,1789) 'quabas(1) = ', quabas(1),
 200      >                   'arete 1 = ', arequa(quabas(1),1),
 201      >                   ' de ',somare(1,arequa(quabas(1),1)),
 202      >                   ' a ',somare(2,arequa(quabas(1),1))
 203       write(ulsort,1789) 'quabas(2) = ', quabas(2),
 204      >                   'arete 1 = ', arequa(quabas(2),1),
 205      >                   ' de ',somare(1,arequa(quabas(2),1)),
 206      >                   ' a ',somare(2,arequa(quabas(2),1))
 207       write(ulsort,1789) 'quabas(3) = ', quabas(3),
 208      >                   'arete 1 = ', arequa(quabas(3),1),
 209      >                   ' de ',somare(1,arequa(quabas(3),1)),
 210      >                   ' a ',somare(2,arequa(quabas(3),1))
 211       write(ulsort,1789) 'quabas(4) = ', quabas(4),
 212      >                   'arete 1 = ', arequa(quabas(4),1),
 213      >                   ' de ',somare(1,arequa(quabas(4),1)),
 214      >                   ' a ',somare(2,arequa(quabas(4),1))
 215 #endif
 216 c
 217 c====
 218 c 5. Aretes tracees sur la face coupee en 4
 219 c    arefad(p) est l'arete commune aux pyramides filles numero p et p+1
 220 c====
 221 c
 222       if ( cofdec.lt.5 ) then
 223        arefad(1) = arequa(quabas(1),2)
 224        arefad(2) = arequa(quabas(2),2)
 225        arefad(3) = arequa(quabas(3),2)
 226        arefad(4) = arequa(quabas(4),2)
 227       else
 228        arefad(1) = arequa(quabas(2),2)
 229        arefad(2) = arequa(quabas(3),2)
 230        arefad(3) = arequa(quabas(4),2)
 231        arefad(4) = arequa(quabas(1),2)
 232       endif
 233 #ifdef _DEBUG_HOMARD_
 234       write(ulsort,1789) 'arefad(1) = ', arefad(1),
 235      >                   ' de ',somare(1,arefad(1)),
 236      >                   ' a ',somare(2,arefad(1))
 237       write(ulsort,1789)
 238      >                   'arefad(2) = ', arefad(2),
 239      >                   ' de ',somare(1,arefad(2)),
 240      >                   ' a ',somare(2,arefad(2))
 241       write(ulsort,1789)
 242      >                   'arefad(3) = ', arefad(3),
 243      >                   ' de ',somare(1,arefad(3)),
 244      >                   ' a ',somare(2,arefad(3))
 245       write(ulsort,1789)
 246      >                   'arefad(4) = ', arefad(4),
 247      >                   ' de ',somare(1,arefad(4)),
 248      >                   ' a ',somare(2,arefad(4))
 249 #endif
 250 c
 251 c====
 252 c 6. Triangles et aretes tracees sur les faces coupees en 3
 253 c            Chaque quadrangle de bord qui est decoupe en 3 triangles
 254 c            borde deux pyramides consecutives : p et p+1
 255 c     trifad(p,0) : triangle central de ce decoupage
 256 c     trifad(p,1) : triangle bordant la pyramide p
 257 c     trifad(p,2) : triangle bordant la pyramide p+1
 258 c     cotrvo(p,0) : futur code du triangle trifad(p,0) dans la
 259 c                   description du tetraedre p
 260 c     cotrvo(p,1) : futur code du triangle trifad(p,1) dans la
 261 c                   description de la pyramide p
 262 c     cotrvo(p,2) : futur code du triangle trifad(p,2) dans la
 263 c                   description de la pyramide p+1
 264 c     areqtr(p,1) : arete interne au quadrangle de bord et bordant le
 265 c                   triangle trifad(p,1)
 266 c     areqtr(p,2) : arete interne au quadrangle de bord et bordant le
 267 c                   triangle trifad(p,2)
 268 c====
 269 c
 270       do 61 , iaux = 1 , 4
 271         jaux = quahex(lehexa,tabaux(iaux))
 272         kaux = coquhe(lehexa,tabaux(iaux))
 273         trifad(iaux,0) = -filqua(jaux)
 274         if ( kaux.lt.5 ) then
 275           cotrvo(iaux,0) = 4
 276           trifad(iaux,1) = trifad(iaux,0) + 1
 277           cotrvo(iaux,1) = 3
 278           trifad(iaux,2) = trifad(iaux,0) + 2
 279           cotrvo(iaux,2) = 2
 280           areqtr(iaux,1) = aretri(trifad(iaux,0),1)
 281           areqtr(iaux,2) = aretri(trifad(iaux,0),3)
 282         else
 283           cotrvo(iaux,0) = 2
 284           trifad(iaux,1) = trifad(iaux,0) + 2
 285           cotrvo(iaux,1) = 5
 286           trifad(iaux,2) = trifad(iaux,0) + 1
 287           cotrvo(iaux,2) = 6
 288           areqtr(iaux,1) = aretri(trifad(iaux,0),3)
 289           areqtr(iaux,2) = aretri(trifad(iaux,0),1)
 290         endif
 291 #ifdef _DEBUG_HOMARD_
 292       write(ulsort,*) ' '
 293       write(ulsort,1789) 'face = ', jaux,', code = ', kaux
 294       write(ulsort,1792) 'trifad(',iaux,',0) = ', trifad(iaux,0)
 295       write(ulsort,1792) 'trifad(',iaux,',1) = ', trifad(iaux,1),
 296      >                   'trifad(',iaux,',2) = ', trifad(iaux,2)
 297       write(ulsort,1792) 'cotrvo(',iaux,',0) = ', cotrvo(iaux,0),
 298      >                   'cotrvo(',iaux,',1) = ', cotrvo(iaux,1),
 299      >                   'cotrvo(',iaux,',2) = ', cotrvo(iaux,2)
 300       write(ulsort,1789) 'areqtr(',iaux,'1) = ', areqtr(iaux,1),
 301      >                   ' de ',somare(1,areqtr(iaux,1)),
 302      >                   ' a ',somare(2,areqtr(iaux,1))
 303       write(ulsort,1789) 'areqtr(',iaux,'2) = ', areqtr(iaux,2),
 304      >                   ' de ',somare(1,areqtr(iaux,2)),
 305      >                   ' a ',somare(2,areqtr(iaux,2))
 306 #endif
 307    61 continue
 308 c
 309 c====
 310 c 7. niveau = niveau des quadrangles des conformites des faces
 311 c====
 312 c
 313       niveau = nivtri(trifad(1,0))
 314 #ifdef _DEBUG_HOMARD_
 315       write(ulsort,1789) 'niveau = ', niveau
 316 #endif
 317 c
 318 c====
 319 c 8. la fin
 320 c====
 321 c
 322       if ( codret.ne.0 ) then
 323 c
 324 #include "envex2.h"
 325 c
 326       write (ulsort,texte(langue,1)) 'Sortie', nompro
 327       write (ulsort,texte(langue,2)) codret
 328 c
 329       endif
 330 c
 331 #ifdef _DEBUG_HOMARD_
 332       write (ulsort,texte(langue,1)) 'Sortie', nompro
 333       call dmflsh (iaux)
 334 #endif
 335 c
 336       end