src/tool/Creation_Maillage/cmchak.F

   1       subroutine cmchak ( nulofa, lehexa,
   2      >                    somare,
   3      >                    aretri, nivtri,
   4      >                    filqua,
   5      >                    quahex, coquhe,
   6      >                    niveau, areqtr,
   7      >                    trifad, cotrvo,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    Creation du Maillage - Conformite - decoupage des Hexaedres
  30 c    -           -          -                          -
  31 c                         - par 3 Aretes - phase K
  32 c                                 -              -
  33 c    Remarque : cmchaa, cmchak et cmchal sont des clones
  34 c               cmchak et cmchal sont symetriques
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . nulofa . e   .   6    . numero local des faces a traiter           .
  40 c . lehexa . e   .   1    . hexaedre a decouper                        .
  41 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  42 c . aretri . es  .nouvtr*3. numeros des 3 aretes des triangles         .
  43 c . nivtri . es  . nouvtr . niveau des triangles                       .
  44 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  45 c . quahex . e   .nouvhf*6. numeros des 6 quadrangles des hexaedres    .
  46 c . coquhe . e   .nouvhf*6. codes des 6 quadrangles des hexaedres      .
  47 c . niveau .  s  .   1    . niveau des faces issus du decoupage        .
  48 c . areqtr .  s  .  (6,2) . aretes tracees sur les faces decoupees     .
  49 c . trifad .  s  .(6,0:2) . triangles traces sur les faces decoupees   .
  50 c . cotrvo .  s  .(6,0:2) . code des triangles dans les volumes        .
  51 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  52 c . langue . e   .    1   . langue des messages                        .
  53 c .        .     .        . 1 : francais, 2 : anglais                  .
  54 c . codret . es  .    1   . code de retour des modules                 .
  55 c .        .     .        . 0 : pas de probleme                        .
  56 c .        .     .        . 1 : aucune arete ne correspond             .
  57 c ______________________________________________________________________
  58 c
  59 c====
  60 c 0. declarations et dimensionnement
  61 c====
  62 c
  63 c 0.1. ==> generalites
  64 c
  65       implicit none
  66       save
  67 c
  68       character*6 nompro
  69       parameter ( nompro = 'CMCHAK' )
  70 c
  71 #include "nblang.h"
  72 c
  73 c 0.2. ==> communs
  74 c
  75 #include "envex1.h"
  76 c
  77 #include "nouvnb.h"
  78 c
  79 c 0.3. ==> arguments
  80 c
  81       integer lehexa, nulofa(6)
  82       integer somare(2,nouvar)
  83       integer aretri(nouvtr,3), nivtri(nouvtr)
  84       integer filqua(nouvqu)
  85       integer quahex(nouvhf,6), coquhe(nouvhf,6)
  86       integer niveau
  87       integer areqtr(6,2)
  88       integer trifad(6,0:2), cotrvo(6,0:2)
  89 c
  90       integer ulsort, langue, codret
  91 c
  92 c 0.4. ==> variables locales
  93 c
  94       integer iaux, jaux
  95 c
  96       integer nbmess
  97       parameter ( nbmess = 10 )
  98       character*80 texte(nblang,nbmess)
  99 c
 100 c 0.5. ==> initialisations
 101 c ______________________________________________________________________
 102 c
 103 c====
 104 c 1. initialisations
 105 c====
 106 c
 107 #include "impr01.h"
 108 c
 109 #ifdef _DEBUG_HOMARD_
 110       write (ulsort,texte(langue,1)) 'Entree', nompro
 111       call dmflsh (iaux)
 112 #endif
 113 c
 114 #ifdef _DEBUG_HOMARD_
 115  1789 format(5(a,i5,', '))
 116 #endif
 117 c
 118       codret = 0
 119 c
 120 c====
 121 c 2. Triangles et aretes tracees sur les faces coupees en 3
 122 c            On traite les faces de l'hexaedre coupees en 3 comme suit :
 123 c            . La 1ere et la 2eme partagent la 1ere arete coupee.
 124 c              La 1ere face est celle qui n'a pas de point commun
 125 c              avec la 2eme arete coupee.
 126 c            . La 3eme et la 4eme partagent la 2nde arete coupee.
 127 c              La 3eme face est celle qui n'a pas de point commun
 128 c              avec la 3eme arete coupee.
 129 c            . La 5eme et la 6eme partagent la 3eme arete coupee.
 130 c              La 5eme face est celle qui n'a pas de point commun
 131 c              avec la 1ere arete coupee.
 132 c            On traite les sommets de l'hexaedre comme suit :
 133 c            . le 1er et le 2eme sommet sont les extremites de la 1ere
 134 c              arete coupee ; le 1er est celui appartenant a
 135 c              la 3eme face.
 136 c            . le 3eme et le 4eme sommet sont les extremites de la 2eme
 137 c              arete coupee ; le 3eme est celui appartenant a
 138 c              la 5eme face.
 139 c            . le 5eme et le 6eme sommet sont les extremites de la 3eme
 140 c              arete coupee ; le 5eme est celui appartenant a
 141 c              la 1ere face.
 142 c            . le 7eme sommet est le dernier sommet de la 1ere face
 143 c            . le 8eme sommet est le dernier sommet de la 2eme face
 144 c     Sur la p-eme face :
 145 c     trifad(p,0) : triangle central de ce decoupage
 146 c     trifad(p,1) : triangle bordant l'arete non decoupee du cote du
 147 c                   sommet de plus petit numero dans lesnoe
 148 c     trifad(p,2) : triangle bordant l'arete non decoupee du cote du
 149 c                   sommet de grand petit numero dans lesnoe
 150 c     cotrvo(p,0/1/2) : futur code du triangle trifad(p,0/1/2) dans la
 151 c                       description du tetraedre voisin
 152 c     areqtr(p,1) : arete interne au quadrangle de bord et bordant le
 153 c                   triangle trifad(p,1)
 154 c     areqtr(p,2) : arete interne au quadrangle de bord et bordant le
 155 c                   triangle trifad(p,2)
 156 c====
 157 c
 158 c 2.1. ==> Face 1
 159 c     trifad(1,0) = triangle central de la face 1 : FFi
 160 c     trifad(1,1) = triangle de la face 1 vers le sommet 1 : FFi + 2/1
 161 c     trifad(1,2) = triangle de la face 1 de l'autre cote : FFi + 1/2
 162 c     areqtr(1,1)
 163 c     areqtr(1,2)
 164       iaux = quahex(lehexa,nulofa(1))
 165       jaux = coquhe(lehexa,nulofa(1))
 166       trifad(1,0) = -filqua(iaux)
 167       if ( jaux.lt.5 ) then
 168         cotrvo(1,0) = 4
 169         trifad(1,2) = trifad(1,0) + 2
 170         cotrvo(1,2) = 6
 171         trifad(1,1) = trifad(1,0) + 1
 172         cotrvo(1,1) = 4
 173         areqtr(1,2) = aretri(trifad(1,0),3)
 174         areqtr(1,1) = aretri(trifad(1,0),1)
 175       else
 176         cotrvo(1,0) = 2
 177         trifad(1,2) = trifad(1,0) + 1
 178         cotrvo(1,2) = 2
 179         trifad(1,1) = trifad(1,0) + 2
 180         cotrvo(1,1) = 1
 181         areqtr(1,2) = aretri(trifad(1,0),1)
 182         areqtr(1,1) = aretri(trifad(1,0),3)
 183       endif
 184 #ifdef _DEBUG_HOMARD_
 185       write(ulsort,*) 'Face 1'
 186       write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux
 187       write(ulsort,1789) 'trifad(1,0) = ', trifad(1,0),
 188      >                   'trifad(1,1) = ', trifad(1,1),
 189      >                   'trifad(1,2) = ', trifad(1,2)
 190       write(ulsort,1789) 'cotrvo(1,0) = ', cotrvo(1,0),
 191      >                   'cotrvo(1,1) = ', cotrvo(1,1),
 192      >                   'cotrvo(1,2) = ', cotrvo(1,2)
 193       write(ulsort,1789) 'areqtr(1,1) = ', areqtr(1,1),
 194      >                   ' de ',somare(1,areqtr(1,1)),
 195      >                   ' a ',somare(2,areqtr(1,1))
 196       write(ulsort,1789) 'areqtr(1,2) = ', areqtr(1,2),
 197      >                   ' de ',somare(1,areqtr(1,2)),
 198      >                   ' a ',somare(2,areqtr(1,2))
 199 #endif
 200 c
 201 c 2.2. ==> Face 2
 202 c     trifad(2,0) = triangle central de la face 2 : FFi
 203 c     trifad(2,1) = triangle de la face 2 vers le sommet 1 : FFi + 1/2
 204 c     trifad(2,2) = triangle de la face 2 de l'autre cote : FFi + 2/1
 205 c     areqtr(2,1)
 206 c     areqtr(2,2)
 207       iaux = quahex(lehexa,nulofa(2))
 208       jaux = coquhe(lehexa,nulofa(2))
 209       trifad(2,0) = -filqua(iaux)
 210       if ( jaux.lt.5 ) then
 211         cotrvo(2,0) = 4
 212         trifad(2,2) = trifad(2,0) + 1
 213         cotrvo(2,2) = 4
 214         trifad(2,1) = trifad(2,0) + 2
 215         cotrvo(2,1) = 6
 216         areqtr(2,2) = aretri(trifad(2,0),1)
 217         areqtr(2,1) = aretri(trifad(2,0),3)
 218       else
 219         cotrvo(2,0) = 2
 220         trifad(2,2) = trifad(2,0) + 2
 221         cotrvo(2,2) = 1
 222         trifad(2,1) = trifad(2,0) + 1
 223         cotrvo(2,1) = 2
 224         areqtr(2,2) = aretri(trifad(2,0),3)
 225         areqtr(2,1) = aretri(trifad(2,0),1)
 226       endif
 227 #ifdef _DEBUG_HOMARD_
 228       write(ulsort,*) 'Face 2'
 229       write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux
 230       write(ulsort,1789) 'trifad(2,0) = ', trifad(2,0),
 231      >                   'trifad(2,1) = ', trifad(2,1),
 232      >                   'trifad(2,2) = ', trifad(2,2)
 233       write(ulsort,1789) 'cotrvo(2,0) = ', cotrvo(2,0),
 234      >                   'cotrvo(2,1) = ', cotrvo(2,1),
 235      >                   'cotrvo(2,2) = ', cotrvo(2,2)
 236       write(ulsort,1789) 'areqtr(2,1) = ', areqtr(2,1),
 237      >                   ' de ',somare(1,areqtr(2,1)),
 238      >                   ' a ',somare(2,areqtr(2,1))
 239       write(ulsort,1789) 'areqtr(2,2) = ', areqtr(2,2),
 240      >                   ' de ',somare(1,areqtr(2,2)),
 241      >                   ' a ',somare(2,areqtr(2,2))
 242 #endif
 243 c
 244 c 2.3. ==> Face 3
 245 c     trifad(3,0) = triangle central de la face 3 : FFi
 246 c     trifad(3,1) = triangle de la face 3 vers le sommet 3 : FFi + 1/2
 247 c     trifad(3,2) = triangle de la face 3 de l'autre cote : FFi + 2/1
 248 c     areqtr(3,1)
 249 c     areqtr(3,2)
 250       iaux = quahex(lehexa,nulofa(3))
 251       jaux = coquhe(lehexa,nulofa(3))
 252       trifad(3,0) = -filqua(iaux)
 253       if ( jaux.lt.5 ) then
 254         cotrvo(3,0) = 4
 255         trifad(3,2) = trifad(3,0) + 2
 256         cotrvo(3,2) = 6
 257         trifad(3,1) = trifad(3,0) + 1
 258         cotrvo(3,1) = 4
 259         areqtr(3,2) = aretri(trifad(3,0),3)
 260         areqtr(3,1) = aretri(trifad(3,0),1)
 261       else
 262         cotrvo(3,0) = 2
 263         trifad(3,2) = trifad(3,0) + 1
 264         cotrvo(3,2) = 2
 265         trifad(3,1) = trifad(3,0) + 2
 266         cotrvo(3,1) = 1
 267         areqtr(3,2) = aretri(trifad(3,0),1)
 268         areqtr(3,1) = aretri(trifad(3,0),3)
 269       endif
 270 #ifdef _DEBUG_HOMARD_
 271       write(ulsort,*) 'Face 3'
 272       write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux
 273       write(ulsort,1789) 'trifad(3,0) = ', trifad(3,0),
 274      >                   'trifad(3,1) = ', trifad(3,1),
 275      >                   'trifad(3,2) = ', trifad(3,2)
 276       write(ulsort,1789) 'cotrvo(3,0) = ', cotrvo(3,0),
 277      >                   'cotrvo(3,1) = ', cotrvo(3,1),
 278      >                   'cotrvo(3,2) = ', cotrvo(3,2)
 279       write(ulsort,1789) '1 = ', aretri(trifad(3,0),1),
 280      >                   '2 = ', aretri(trifad(3,0),2),
 281      >                   '3 = ', aretri(trifad(3,0),3)
 282       write(ulsort,1789) '1 = ', aretri(trifad(3,1),1),
 283      >                   '2 = ', aretri(trifad(3,1),2),
 284      >                   '3 = ', aretri(trifad(3,1),3)
 285       write(ulsort,1789) '1 = ', aretri(trifad(3,2),1),
 286      >                   '2 = ', aretri(trifad(3,2),2),
 287      >                   '3 = ', aretri(trifad(3,2),3)
 288       write(ulsort,1789) 'areqtr(3,1) = ', areqtr(3,1),
 289      >                   ' de ',somare(1,areqtr(3,1)),
 290      >                   ' a ',somare(2,areqtr(3,1))
 291       write(ulsort,1789) 'areqtr(3,2) = ', areqtr(3,2),
 292      >                   ' de ',somare(1,areqtr(3,2)),
 293      >                   ' a ',somare(2,areqtr(3,2))
 294 #endif
 295 c
 296 c 2.4. ==> Face 4
 297 c     trifad(4,0) = triangle central de la face 4 : FFi
 298 c     trifad(4,1) = triangle de la face 4 vers le sommet 3 : FFi + 1/2
 299 c     trifad(4,2) = triangle de la face 4 de l'autre cote : FFi + 2/1
 300 c     areqtr(4,1)
 301 c     areqtr(4,2)
 302       iaux = quahex(lehexa,nulofa(4))
 303       jaux = coquhe(lehexa,nulofa(4))
 304       trifad(4,0) = -filqua(iaux)
 305       if ( jaux.lt.5 ) then
 306         cotrvo(4,0) = 4
 307         trifad(4,2) = trifad(4,0) + 1
 308         cotrvo(4,2) = 4
 309         trifad(4,1) = trifad(4,0) + 2
 310         cotrvo(4,1) = 6
 311         areqtr(4,2) = aretri(trifad(4,0),1)
 312         areqtr(4,1) = aretri(trifad(4,0),3)
 313       else
 314         cotrvo(4,0) = 2
 315         trifad(4,2) = trifad(4,0) + 2
 316         cotrvo(4,2) = 1
 317         trifad(4,1) = trifad(4,0) + 1
 318         cotrvo(4,1) = 2
 319         areqtr(4,2) = aretri(trifad(4,0),3)
 320         areqtr(4,1) = aretri(trifad(4,0),1)
 321       endif
 322 #ifdef _DEBUG_HOMARD_
 323       write(ulsort,*) 'Face 4'
 324       write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux
 325       write(ulsort,1789) 'trifad(4,0) = ', trifad(4,0),
 326      >                   'trifad(4,1) = ', trifad(4,1),
 327      >                   'trifad(4,2) = ', trifad(4,2)
 328       write(ulsort,1789) 'cotrvo(4,0) = ', cotrvo(4,0),
 329      >                   'cotrvo(4,1) = ', cotrvo(4,1),
 330      >                   'cotrvo(4,2) = ', cotrvo(4,2)
 331       write(ulsort,1789) 'areqtr(4,1) = ', areqtr(4,1),
 332      >                   ' de ',somare(1,areqtr(4,1)),
 333      >                   ' a ',somare(2,areqtr(4,1))
 334       write(ulsort,1789) 'areqtr(4,2) = ', areqtr(4,2),
 335      >                   ' de ',somare(1,areqtr(4,2)),
 336      >                   ' a ',somare(2,areqtr(4,2))
 337 #endif
 338 c
 339 c 2.5. ==> Face 5
 340 c     trifad(5,0) = triangle central de la face 5 : FFi
 341 c     trifad(5,1) = triangle de la face 5 du cote du sommet 5 : FFi + 1/2
 342 c     trifad(5,2) = triangle de la face 5 de l'autre cote : FFi + 2/1
 343 c     areqtr(5,1)
 344 c     areqtr(5,2)
 345       iaux = quahex(lehexa,nulofa(5))
 346       jaux = coquhe(lehexa,nulofa(5))
 347       trifad(5,0) = -filqua(iaux)
 348       if ( jaux.lt.5 ) then
 349         cotrvo(5,0) = 4
 350         trifad(5,2) = trifad(5,0) + 2
 351         cotrvo(5,2) = 6
 352         trifad(5,1) = trifad(5,0) + 1
 353         cotrvo(5,1) = 4
 354         areqtr(5,2) = aretri(trifad(5,0),3)
 355         areqtr(5,1) = aretri(trifad(5,0),1)
 356       else
 357         cotrvo(5,0) = 2
 358         trifad(5,2) = trifad(5,0) + 1
 359         cotrvo(5,2) = 2
 360         trifad(5,1) = trifad(5,0) + 2
 361         cotrvo(5,1) = 1
 362         areqtr(5,2) = aretri(trifad(5,0),1)
 363         areqtr(5,1) = aretri(trifad(5,0),3)
 364       endif
 365 #ifdef _DEBUG_HOMARD_
 366       write(ulsort,*) 'Face 5'
 367       write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux
 368       write(ulsort,1789) 'trifad(5,0) = ', trifad(5,0),
 369      >                   'trifad(5,1) = ', trifad(5,1),
 370      >                   'trifad(5,2) = ', trifad(5,2)
 371       write(ulsort,1789) 'cotrvo(5,0) = ', cotrvo(5,0),
 372      >                   'cotrvo(5,1) = ', cotrvo(5,1),
 373      >                   'cotrvo(5,2) = ', cotrvo(5,2)
 374       write(ulsort,1789) 'areqtr(5,1) = ', areqtr(5,1),
 375      >                   ' de ',somare(1,areqtr(5,1)),
 376      >                   ' a ',somare(2,areqtr(5,1))
 377       write(ulsort,1789) 'areqtr(5,2) = ', areqtr(5,2),
 378      >                   ' de ',somare(1,areqtr(5,2)),
 379      >                   ' a ',somare(2,areqtr(5,2))
 380 #endif
 381 c
 382 c 2.6. ==> Face 6
 383 c     trifad(6,0) = triangle central de la face 6 : FFi
 384 c     trifad(6,1) = triangle de la face 6 du cote du sommet 5 : FFi + 1/2
 385 c     trifad(6,2) = triangle de la face 6 de l'autre cote : FFi + 2/1
 386 c     areqtr(6,1)
 387 c     areqtr(6,2)
 388       iaux = quahex(lehexa,nulofa(6))
 389       jaux = coquhe(lehexa,nulofa(6))
 390       trifad(6,0) = -filqua(iaux)
 391       if ( jaux.lt.5 ) then
 392         cotrvo(6,0) = 4
 393         trifad(6,2) = trifad(6,0) + 1
 394         cotrvo(6,2) = 4
 395         trifad(6,1) = trifad(6,0) + 2
 396         cotrvo(6,1) = 6
 397         areqtr(6,2) = aretri(trifad(6,0),1)
 398         areqtr(6,1) = aretri(trifad(6,0),3)
 399       else
 400         cotrvo(6,0) = 2
 401         trifad(6,2) = trifad(6,0) + 2
 402         cotrvo(6,2) = 1
 403         trifad(6,1) = trifad(6,0) + 1
 404         cotrvo(6,1) = 2
 405         areqtr(6,2) = aretri(trifad(6,0),3)
 406         areqtr(6,1) = aretri(trifad(6,0),1)
 407       endif
 408 #ifdef _DEBUG_HOMARD_
 409       write(ulsort,*) 'Face 6'
 410       write(ulsort,1789) 'laface = ', iaux,'coface = ', jaux
 411       write(ulsort,1789) 'trifad(6,0) = ', trifad(6,0),
 412      >                   'trifad(6,1) = ', trifad(6,1),
 413      >                   'trifad(6,2) = ', trifad(6,2)
 414       write(ulsort,1789) 'cotrvo(6,0) = ', cotrvo(6,0),
 415      >                   'cotrvo(6,1) = ', cotrvo(6,1),
 416      >                   'cotrvo(6,2) = ', cotrvo(6,2)
 417       write(ulsort,1789) 'areqtr(6,1) = ', areqtr(6,1),
 418      >                   ' de ',somare(1,areqtr(6,1)),
 419      >                   ' a ',somare(2,areqtr(6,1))
 420       write(ulsort,1789) 'areqtr(6,2) = ', areqtr(6,2),
 421      >                   ' de ',somare(1,areqtr(6,2)),
 422      >                   ' a ',somare(2,areqtr(6,2))
 423 #endif
 424 c
 425 c====
 426 c 3. grandeurs independantes du cas traite (phase 2)
 427 c====
 428 c     niveau = niveau des triangles des conformites des faces
 429       niveau = nivtri(trifad(1,0))
 430 #ifdef _DEBUG_HOMARD_
 431       write(ulsort,3000) niveau
 432  3000 format('niveau =',i3)
 433 #endif
 434 c
 435 c====
 436 c 4. la fin
 437 c====
 438 c
 439       if ( codret.ne.0 ) then
 440 c
 441 #include "envex2.h"
 442 c
 443       write (ulsort,texte(langue,1)) 'Sortie', nompro
 444       write (ulsort,texte(langue,2)) codret
 445 c
 446       endif
 447 c
 448 #ifdef _DEBUG_HOMARD_
 449       write (ulsort,texte(langue,1)) 'Sortie', nompro
 450       call dmflsh (iaux)
 451 #endif
 452 c
 453       end