src/tool/Modification/mmag33.F

   1       subroutine mmag33 ( indhex,
   2      >                    nbduno, nbduar,
   3      >                    nbpejt, nbhejq, nbvojm, nbjoto,
   4      >                    nbjois, nbjoit,
   5      >                    tbaux2, tbau30, tbau40,
   6      >                    tbau41,
   7      >                    nbhe12, tbau53,
   8      >                    nbpe09, tbau52,
   9      >                    coonoe, somare,
  10      >                    arequa, hetqua,
  11      >                    filqua, perqua, nivqua,
  12      >                    quahex, coquhe,
  13      >                    hethex, filhex, perhex,
  14      >                    famqua, famhex,
  15      >                    ulsort, langue, codret )
  16 c ______________________________________________________________________
  17 c
  18 c                             H O M A R D
  19 c
  20 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  21 c
  22 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  23 c aupres des huissiers de justice Simart et Lavoir a Clamart
  24 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  25 c aupres des huissiers de justice
  26 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  27 c
  28 c    HOMARD est une marque deposee d'Electricite de France
  29 c
  30 c Copyright EDF 1996
  31 c Copyright EDF 1998
  32 c Copyright EDF 2002
  33 c Copyright EDF 2020
  34 c ______________________________________________________________________
  35 c
  36 c    Modification de Maillage - AGRegat - phase 3.3
  37 c    -               -          --              - -
  38 c    Creation des mailles pour les joints quadruples :
  39 c    . hexaedres
  40 c    Et donc des quadrangles supplementaires
  41 c ______________________________________________________________________
  42 c .        .     .        .                                            .
  43 c .  nom   . e/s . taille .           description                      .
  44 c .____________________________________________________________________.
  45 c . indhex . es  .   1    . indice du dernier hexaedre cree            .
  46 c . nbduno . e   .   1    . nombre de duplication de noeuds            .
  47 c . nbduar . e   .   1    . nombre de duplications d'aretes            .
  48 c . nbpejt . e   .   1    . nombre de pentaedres de joints triples     .
  49 c . nbhejq . e   .   1    . nombre d'hexaedres de joints quadruples    .
  50 c . nbvojm . e   .   1    . nombre de volumes de joints multiples      .
  51 c . nbjoto . e   .   1    . nombre total de joints                     .
  52 c . nbjois . e   .   1    . nombre de joints simples                   .
  53 c . nbjoit . e   .   1    . nombre de joints triples                   .
  54 c . tbaux2 . e   .4*nbjoto. Pour le i-eme joint :                      .
  55 c .        .     .        . Numeros des familles MED des volumes       .
  56 c .        .     .        . jouxtant le pentaedre/hexaedre, classes du .
  57 c .        .     .        . plus petit (1,i) au plus grand             .
  58 c .        .     .        . 0, si pas de volume voisin                 .
  59 c . tbau30 . e   .8*nbduno. Pour la i-eme duplication de noeud :       .
  60 c .        .     .        . (1,i) : noeud a dupliquer                  .
  61 c .        .     .        . (2,i) : arete construite sur le noeud      .
  62 c .        .     .        . (3,i) : noeud cree cote min(fammed)        .
  63 c .        .     .        . (4,i) : noeud cree cote max(fammed)        .
  64 c .        .     .        . (5,i) : numero du joint simple cree        .
  65 c .        .     .        . (6,i) : arete entrant dans le cote 1       .
  66 c .        .     .        . (7,i) : arete entrant dans le cote 2       .
  67 c .        .     .        . (8,i) : ordre de multiplicite              .
  68 c . tbau40 . e   .6*nbduar. Pour la i-eme duplication d'arete :        .
  69 c .        .     .        . (1,i) : arete a dupliquer                  .
  70 c .        .     .        . (2,i) : arete creee cote min(fammed)       .
  71 c .        .     .        . (3,i) : arete creee cote max(fammed)       .
  72 c .        .     .        . (4,i) : numero du joint simple cree        .
  73 c .        .     .        . (5,i) : ordre de multiplicite              .
  74 c .        .     .        . (6,i) : arete d'orientation de joint       .
  75 c . tbau41 . e   .4*nbvojm. Les pentaedres de joint triple, puis les   .
  76 c .        .     .        . hexaedres de joint quadruple :             .
  77 c .        .     .        . (1,i) : arete multiple                     .
  78 c .        .     .        . (2,i) : numero du joint                    .
  79 c .        .     .        . Pour le i-eme pentaedre de joint triple :  .
  80 c .        .     .        . (3,i) : triangle cree cote 1er sommet      .
  81 c .        .     .        . (4,i) : triangle cree cote 2nd sommet      .
  82 c .        .     .        . Pour le i-eme hexaedre de joint quadruple :.
  83 c .        .     .        . (3,i) : quadrangle cree cote 1er sommet    .
  84 c .        .     .        . (4,i) : quadrangle cree cote 2nd sommet    .
  85 c . nbhe12 . e   .   1    . nombre de hexa. des j. ponctuels d'ordre 12.
  86 c . tbau53 . es  .  13*   . Les hexaedres ponctuels entre les joints   .
  87 c .        .     . nbhe12 . quadruples (ordre 12) :                    .
  88 c .        .     .        . (1,i) : noeud multiple                     .
  89 c .        .     .        . (2,i) : quadrangle cote du 1er joint quad. .
  90 c .        .     .        . (3,i) : quadrangle cote du 2eme joint quad..
  91 c .        .     .        . (4,i) : quadrangle cote du 3eme joint quad..
  92 c .        .     .        . (5,i) : quadrangle cote du 4eme joint quad..
  93 c .        .     .        . (6,i) : quadrangle cote du 5eme joint quad..
  94 c .        .     .        . (7,i) : quadrangle cote du 6eme joint quad..
  95 c .        .     .        . (1+k) : pour le k-eme quadrangle, 1 s'il   .
  96 c .        .     .        . entre dans le joint ponctuel, -1 sinon     .
  97 c . nbpe09 . e   .   1    . nombre de pent. des j. ponctuels d'ordre 9 .
  98 c . tbau52 . es  .  11*   . Les pentaedres ponctuels entre les joints  .
  99 c .        .     . nbpe09 . triples et quadruples :                    .
 100 c .        .     .        . (1,i) : noeud multiple                     .
 101 c .        .     .        . (2,i) : triangle cote du 1er joint triple  .
 102 c .        .     .        . (3,i) : triangle cote du 2eme joint triple .
 103 c .        .     .        . (4,i) : quadrangle cote du 1er joint quad. .
 104 c .        .     .        . (5,i) : quadrangle cote du 2eme joint quad..
 105 c .        .     .        . (6,i) : quadrangle cote du 3eme joint quad..
 106 c .        .     .        . (1+k) : pour la k-eme face, 1 si elle      .
 107 c .        .     .        . entre dans le joint ponctuel, -1 sinon     .
 108 c . coonoe . e   .nbnoto*3. coordonnees des noeuds                     .
 109 c . somare . es  .2*nbarto. numeros des extremites d'arete             .
 110 c . arequa . e   .nbquto*4. numeros des 3 aretes des quadrangles       .
 111 c . hetqua . es  . nbquto . historique de l'etat des quadrangles       .
 112 c . filqua . es  . nbquto . premier fils des quadrangles               .
 113 c . perqua . es  . nbquto . pere des quadrangles                       .
 114 c . nivqua . es  . nbquto . niveau des quadrangles                     .
 115 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
 116 c . quahex . es  .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
 117 c . coquhe . es  .nbhecf*6. codes des 6 quadrangles des hexaedres      .
 118 c . hethex . es  . nbheto . historique de l'etat des hexaedres         .
 119 c . filhex . es  . nbheto . premier fils des hexaedres                 .
 120 c . perhex . es  . nbheto . pere des hexaedres                         .
 121 c . famqua . es  . nbquto . famille des quadrangles                    .
 122 c . famhex . es  . nbheto . famille des hexaedres                      .
 123 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 124 c . langue . e   .    1   . langue des messages                        .
 125 c .        .     .        . 1 : francais, 2 : anglais                  .
 126 c . codret . es  .    1   . code de retour des modules                 .
 127 c .        .     .        . 0 : pas de probleme                        .
 128 c ______________________________________________________________________
 129 c
 130 c====
 131 c 0. declarations et dimensionnement
 132 c====
 133 c
 134 c 0.1. ==> generalites
 135 c
 136       implicit none
 137       save
 138 c
 139       character*6 nompro
 140       parameter ( nompro = 'MMAG33' )
 141 c
 142 #include "nblang.h"
 143 c
 144       integer ordre
 145       parameter ( ordre = 4 )
 146 c
 147 c 0.2. ==> communs
 148 c
 149 #include "envex1.h"
 150 c
 151 #include "envca1.h"
 152 #include "nombno.h"
 153 #include "nombar.h"
 154 #include "nombqu.h"
 155 #include "nombhe.h"
 156 #include "impr02.h"
 157 c
 158 c 0.3. ==> arguments
 159 c
 160       integer indhex
 161       integer nbduno, nbduar
 162       integer nbpejt, nbhejq, nbvojm, nbjoto
 163       integer nbjois, nbjoit
 164       integer tbaux2(4,nbjoto)
 165       integer tbau30(8,nbduno), tbau40(6,nbduar)
 166       integer tbau41(4,nbvojm)
 167       integer nbhe12, tbau53(13,nbhe12)
 168       integer nbpe09, tbau52(11,nbpe09)
 169       integer somare(2,nbarto)
 170       integer arequa(nbquto,4), hetqua(nbquto)
 171       integer filqua(nbquto), perqua(nbquto), nivqua(nbquto)
 172       integer quahex(nbhecf,6), coquhe(nbhecf,6)
 173       integer hethex(nbheto), filhex(nbheto), perhex(nbheto)
 174       integer famqua(nbquto), famhex(nbheto)
 175 c
 176       double precision coonoe(nbnoto,sdim)
 177 c
 178       integer ulsort, langue, codret
 179 c
 180 c 0.4. ==> variables locales
 181 c
 182       integer iaux, jaux, kaux, laux
 183       integer ideb, ifin
 184       integer larete
 185       integer lequad(2)
 186       integer nbjoin
 187 c
 188       integer nujoin, nujois(ordre)
 189       integer aredup(2*ordre)
 190       integer arejoi(ordre), quajoi(ordre)
 191       integer nujolo(ordre), nujol2(ordre)
 192       integer a1, a2, a3, a4
 193       integer sa1a2, sa2a3, sa3a4, sa4a1
 194       integer somhex(8), arehex(12), orient
 195       integer tabcod(8)
 196 c
 197       integer nbmess
 198       parameter ( nbmess = 40 )
 199       character*80 texte(nblang,nbmess)
 200 c
 201 c 0.5. ==> initialisations
 202 c ______________________________________________________________________
 203 c
 204       data tabcod / 5, 8, 7, 6, 1, 4, 3, 2 /
 205 c
 206 c====
 207 c 1. initialisations
 208 c====
 209 c 1.1. ==> messages
 210 c
 211 #include "impr01.h"
 212 c
 213 #ifdef _DEBUG_HOMARD_
 214       write (ulsort,texte(langue,1)) 'Entree', nompro
 215       call dmflsh (iaux)
 216 #endif
 217 c
 218 #include "impr03.h"
 219 #include "mmag01.h"
 220 #include "mmag02.h"
 221 c
 222       nbjoin = nbjois + nbjoit
 223 c
 224 #ifdef _DEBUG_HOMARD_
 225       write (ulsort,texte(langue,12)) nbjois
 226       write (ulsort,texte(langue,7)) mess14(langue,3,6), nbhejq
 227       write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno
 228       write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar
 229 #endif
 230 c
 231       codret = 0
 232 c
 233       ideb = nbpejt + 1
 234       ifin = nbpejt + nbhejq
 235 cgn      write (ulsort,90002) 'nbpejt', nbpejt
 236 cgn      write (ulsort,90002) 'nbhejq', nbhejq
 237 cgn      write (ulsort,*) '==> ideb , ifin =', ideb , ifin
 238 c
 239 cgn      write(ulsort,1001) 'nbnoto, nbarto, nbquto',nbnoto, nbarto,nbquto
 240 cgn      write(ulsort,1001) 'nbhejq',nbhejq
 241 cgn      write(ulsort,1000) (iaux,iaux=1,20)
 242 cgn      write(ulsort,1001) 'tbaux2',4,nbjoto
 243 cgn      do 1101 , kaux = 1,nbjoto
 244 cgn       write(ulsort,1000) (tbaux2(jaux,kaux),jaux=1,4)
 245 cgn 1101 continue
 246 cgn      write(ulsort,1001) 'tbau41',4,nbvojm
 247 cgn      do 1102 , kaux = 1,nbvojm
 248 cgn       write(ulsort,1000) (tbau41(jaux,kaux),jaux=1,4)
 249 cgn 1102  continue
 250 cgn 1000 format(10i9)
 251 cgn 1001 format(a,4i6)
 252 c
 253 c====
 254 c 2. Parcours des aretes quadruples / hexaedres de joint quadruple
 255 c====
 256 #ifdef _DEBUG_HOMARD_
 257       write (ulsort,texte(langue,5)) mess14(langue,3,1)
 258 #endif
 259 c
 260 c                 S5            a9             S6
 261 c                  ----------------------------
 262 c                 /.                          /.
 263 c                / .                         / .
 264 c               /  .                        /  .
 265 c              /   .                       /   .
 266 c           a6/    .                      /a5  .
 267 c            /     .                     /     .
 268 c           /   a11.                    /      .a10
 269 c          /       .    a1             /       .
 270 c       S2----------------------------- S1     .
 271 c         .        .                  .        .
 272 c         .        .           a12    .        .
 273 c         .     S8 -------------------.--------.S7
 274 c         .       /                   .       /
 275 c       a3.      /                    .a2    /
 276 c         .     /                     .     /
 277 c         .    /                      .    /
 278 c         . a8/                       .   /a7
 279 c         .  /                        .  /
 280 c         . /                         . /
 281 c         ./                          ./
 282 c         -----------------------------
 283 c        S3            a4             S4
 284 c
 285 c    . Les noeuds (1,2,3,4) definissent un quadrangle a orientation
 286 c      vers l'exterieur
 287 c     Avec le code 1, les faces sont :
 288 c     Face 1 : aretes 1, 2, 4, 3
 289 c     Face 2 : aretes 1, 6, 9, 5
 290 c     Face 3 : aretes 2, 5, 10, 7
 291 c     Face 4 : aretes 3, 8, 11, 6
 292 c     Face 5 : aretes 4, 7, 12, 8
 293 c     Face 6 : aretes 9, 11, 12, 10
 294 c
 295 c  L'arete quadruple se retrouve dans a5, a7, a8, a6.
 296 c  On impose que :
 297 c  Le long de l'arete quadruple :
 298 c  . La face F1 (a1,a2,a4,a3) est definie du cote du 1er sommet et
 299 c     a1 est du cote du 1er joint simple voisin
 300 c  . La face F2 borde le 1er joint simple.c
 301       ideb = nbpejt + 1
 302       ifin = nbpejt + nbhejq
 303 cgn      write (ulsort,90002) 'nbpejt', nbpejt
 304 cgn      write (ulsort,90002) 'nbhejq', nbhejq
 305 cgn      write (ulsort,*) '==> ideb , ifin =', ideb , ifin
 306
 307 c  . La face F3 borde le joint qui suit le 1er.
 308 c  . La face F4 borde le joint qui suit le 2eme.
 309 c  . La face F5 est opposee a F2.
 310 c  . La face F6 (a9,a11,a12,a10) est definie du cote du 2nd sommet :
 311 c     a9 est du cote du 1er joint simple voisin
 312 c
 313 c voir utarhe pour le croquis ci-dessus
 314 c
 315       do 2 , iaux = ideb , ifin
 316 c
 317         indhex = indhex + 1
 318 c
 319         larete = tbau41(1,iaux)
 320 c
 321         nujoin = tbau41(2,iaux)
 322 c
 323 #ifdef _DEBUG_HOMARD_
 324           if ( larete.eq.-8 ) then
 325       write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete
 326       write (ulsort,texte(langue,32)) nujoin - nbjoin
 327               endif
 328 #endif
 329 c
 330 c 2.1. ==> reperage des numeros des 4 joints simples voisins
 331 c
 332         do 21 , jaux = 1 , ordre
 333           nujois(jaux) = tbaux2(jaux,nujoin)
 334    21   continue
 335 #ifdef _DEBUG_HOMARD_
 336         if ( larete.eq.-8 ) then
 337         write (ulsort,texte(langue,39)) nujois
 338         endif
 339 #endif
 340 c
 341 c 2.2. ==> Reperage des aretes qui partent de chacun des noeuds.
 342 C          Elles delimitent les faces 1 et 6 de l'hexaedre en cours.
 343 c
 344 #ifdef _DEBUG_HOMARD_
 345       write (ulsort,texte(langue,3)) 'MMAG91', nompro
 346 #endif
 347         call mmag91 ( larete, ordre, nujois,
 348      >                nbduno, tbau30,
 349      >                somare,
 350      >                aredup,
 351      >                ulsort, langue, codret )
 352 c
 353         if ( codret.ne.0 ) then
 354         write (ulsort,texte(langue,16)) mess14(langue,1,6), indhex, 0
 355         write (ulsort,texte(langue,31)) nujoin
 356         goto 5555
 357         endif
 358 c
 359 c 2.3. ==> Reperage des aretes et des quadrangles batis sur les joints
 360 c
 361 #ifdef _DEBUG_HOMARD_
 362       write (ulsort,texte(langue,3)) 'MMAG92', nompro
 363 #endif
 364         call mmag92 ( larete, ordre, nujois,
 365      >                nbduar, tbau40,
 366      >                arejoi, quajoi,
 367      >                ulsort, langue, codret )
 368 c
 369         if ( codret.ne.0 ) then
 370         write (ulsort,texte(langue,16)) mess14(langue,1,7), indhex, 0
 371         write (ulsort,texte(langue,31)) nujoin
 372         goto 5555
 373         endif
 374 c
 375 #ifdef _DEBUG_HOMARD_
 376           if ( larete.eq.-8 ) then
 377         do 23111 , jaux = 1 , ordre
 378         write (ulsort,90015)'Joint',jaux,', quadrangle',quajoi(jaux)
 379         write (ulsort,90015)'arete de joints',arejoi(jaux),
 380      >   ', de sommets',somare(1,arejoi(jaux)),somare(2,arejoi(jaux))
 381 23111   continue
 382           endif
 383 #endif
 384 c
 385 c 2.4. ==> Determination de l'orientation des joints
 386 c          Par hypothese, la face f2 de l'hexaedre s'appuie sur le 1er
 387 c          joint simple. Ensuite, par definition de l'hexaedre, les
 388 c          faces f3, f5 et f4 arrivent dans le sens positif quand on
 389 c          entre dans l'hexaedre depuis la face f1.
 390 c          On cherche donc le positionnement des 4 joints relativement
 391 c          a l'arete dupliquee et on en deduit l'ordre d'apparition
 392 c          des joints qui creeront les faces f3, f5 et f4.
 393 c          Ensuite, il faut definir un enchainement des aretes de joint
 394 c          dans un ordre coherent.
 395 c          . Soit on suit l'ordre entrant dans l'hexaedre que l'on veut
 396 c            creer ;
 397 c          . Soit on suit l'ordre inverse
 398 c          Il faut que le choix entre les deux soit independant de
 399 c          l'hexaedre car ce quadrangle peut apparaitre pour l'hexaedre
 400 c          courant ou pour son voisin. Et donc le caractere
 401 c          entrant/sortant va changer. On choisira de tourner dans
 402 c          un sens ou dans un autre en fonction du plus petit numero de
 403 c          joint qui suit.
 404 c
 405 #ifdef _DEBUG_HOMARD_
 406       write (ulsort,texte(langue,3)) 'UTORA3', nompro
 407 #endif
 408         call utora4 ( nujolo,
 409      >                larete,
 410      >                arejoi(1), arejoi(2), arejoi(3), arejoi(4),
 411      >                coonoe, somare,
 412      >                ulsort, langue, codret )
 413 c
 414         if ( nujois(nujolo(2)).lt.nujois(nujolo(4)) ) then
 415           orient = 1
 416           nujol2(2) = nujolo(2)
 417           nujol2(4) = nujolo(4)
 418         else
 419           orient = -1
 420           nujol2(2) = nujolo(4)
 421           nujol2(4) = nujolo(2)
 422         endif
 423 #ifdef _DEBUG_HOMARD_
 424       if ( larete.eq.-8 ) then
 425       write (ulsort,90002)'orient',orient
 426       endif
 427 #endif
 428 c
 429 c 2.5. ==> Creation des quadrangles
 430 c          Eventuellement, on recree plusieurs fois le meme quadrangle.
 431 c          Pas grave car il est toujours cree en s'orientant sur les
 432 c          joints simples adjacents.
 433 c
 434         do 25 , jaux = 1 , 2
 435 c
 436 c 2.5.1. ==> Numero du quadrangle
 437 c
 438           kaux = tbau41(2+jaux,iaux)
 439 c
 440 #ifdef _DEBUG_HOMARD_
 441       write (ulsort,texte(langue,16)) mess14(langue,1,4), kaux,
 442      > jaux
 443        write (ulsort,texte(langue,17))
 444      > (aredup(kaux),kaux=ordre*(jaux-1)+1,ordre*jaux)
 445 #endif
 446 c
 447 c 2.5.2. ==> Aretes
 448 c          La 1ere arete est celle jouxtant le 1er joint simple.
 449 c          La 2eme arete est celle qui suit selon la regle precedente.
 450 c          La 3eme arete est celle qui borde le 3eme joint.
 451 c          La 4eme arete est celle qui suit selon la regle precedente.
 452 c
 453           arequa(kaux,1) = aredup(ordre*(jaux-1)+1)
 454           arequa(kaux,2) = aredup(ordre*(jaux-1)+nujol2(2))
 455           arequa(kaux,3) = aredup(ordre*(jaux-1)+nujolo(3))
 456           arequa(kaux,4) = aredup(ordre*(jaux-1)+nujol2(4))
 457 c
 458 c 2.5.3. ==> Caracteristiques
 459 c
 460           famqua(kaux) = 1
 461 c
 462           hetqua(kaux) = 0
 463           filqua(kaux) = 0
 464           perqua(kaux) = 0
 465           nivqua(kaux) = 0
 466 c
 467           lequad(jaux) = kaux
 468 c
 469 c 2.5.4. ==> Impact pour l'eventuel joint ponctuel voisin
 470 c            Pour le 1er quadrangle :
 471 c            . Si l'orientation est positive, le quadrangle entre dans
 472 c              l'hexaedre, donc sort de l'eventuel joint ponctuel
 473 c              voisin : -1 = 2*1 - 3
 474 c            . Sinon, le triangle sort de l'hexaedre, donc entre dans
 475 c              l'eventuel joint ponctuel voisin : 1 = 3 - 2*1
 476 c            Pour le 2nd quadrangle : raisonnement symetrique
 477 c            . Orientation >0, entree :  1 = 2*2 - 3
 478 c            . Orientation <0, sortie : -1 = 3 - 2*2
 479 c
 480           if ( orient.gt.0 ) then
 481             laux = 2*jaux - 3
 482           else
 483             laux = 3 - 2*jaux
 484           endif
 485 c
 486 #ifdef _DEBUG_HOMARD_
 487       write (ulsort,texte(langue,3)) 'MMAG94', nompro
 488 #endif
 489           call mmag94 ( kaux, laux,
 490      >                  nbhe12, tbau53,
 491      >                  nbpe09, tbau52,
 492      >                  ulsort, langue, codret )
 493 c
 494    25   continue
 495 c
 496 c 2.6. ==> Creation de l'hexaedre
 497 c
 498 #ifdef _DEBUG_HOMARD_
 499       write (ulsort,texte(langue,16)) mess14(langue,1,6), indhex, 0
 500 #endif
 501 c
 502 c 2.6.1. ==> La face f1 est le 1er quadrangle.
 503 c   On impose :
 504 c     la 1ere arete de l'hexaedre est la 1ere arete du quadrangle ;
 505 c   --> le code sera donc 1 ou 5.
 506 c   Si l'orientation est positive, le quadrangle entre dans l'hexaedre.
 507 c   On lui donnera donc le code 1.
 508 C   Inversement, si l'orientation est negative, il va sortir
 509 c   de l'hexaedre. On lui donnera alors le code 5.
 510 c
 511         quahex(indhex,1) = lequad(1)
 512         if ( orient.gt.0 ) then
 513           coquhe(indhex,1) = 1
 514         else
 515           coquhe(indhex,1) = 5
 516         endif
 517 c
 518         call utsoqu ( somare,
 519      >                aredup(1), aredup(nujol2(2)),
 520      >                aredup(nujolo(3)), aredup(nujol2(4)),
 521      >                sa1a2, sa2a3, sa3a4, sa4a1 )
 522         arehex(1) = aredup(1)
 523         arehex(2) = aredup(nujolo(2))
 524         arehex(4) = aredup(nujolo(3))
 525         arehex(3) = aredup(nujolo(4))
 526         if ( orient.gt.0 ) then
 527           somhex(1) = sa1a2
 528           somhex(4) = sa2a3
 529           somhex(3) = sa3a4
 530           somhex(2) = sa4a1
 531         else
 532           somhex(1) = sa4a1
 533           somhex(4) = sa3a4
 534           somhex(3) = sa2a3
 535           somhex(2) = sa1a2
 536         endif
 537 #ifdef _DEBUG_HOMARD_
 538           if ( larete.eq.-8 ) then
 539       write (ulsort,90002)'sommets quad',sa1a2, sa2a3, sa3a4, sa4a1
 540       write (ulsort,90002)'sommets hexa 1-4',(somhex(jaux),jaux=1,4)
 541       write (ulsort,90002)'aretes hexa  1-4',(arehex(jaux),jaux=1,4)
 542             endif
 543 #endif
 544 c
 545 c 2.6.2. ==> Face 6 : c'est le quadrangle cree du cote de la fin
 546 c                     de l'arete quadruple.
 547 c   Suite aux choix faits sur f1, sa 1ere arete est a9.
 548 c   Si le code du quadrangle en tant que face 1 est 1, alors sa 2eme
 549 c   arete est la translatee de a2, donc a10, ce qui fait un code 5.
 550 c   Si le code du quadrangle en tant que face 1 est 4, alors sa 2eme
 551 c   arete est la translatee de a3, donc a11, ce qui fait un code 1.
 552 c
 553         quahex(indhex,6) = lequad(2)
 554         coquhe(indhex,6) = tabcod(coquhe(indhex,1))
 555 c
 556         call utsoqu ( somare,
 557      >                aredup(5), aredup(ordre+nujol2(2)),
 558      >                aredup(ordre+nujolo(3)), aredup(ordre+nujol2(4)),
 559      >                sa1a2, sa2a3, sa3a4, sa4a1 )
 560         arehex( 9) = aredup(5)
 561         arehex(10) = aredup(ordre+nujolo(2))
 562         arehex(12) = aredup(ordre+nujolo(3))
 563         arehex(11) = aredup(ordre+nujolo(4))
 564         if ( orient.gt.0 ) then
 565           somhex(6) = sa1a2
 566           somhex(7) = sa2a3
 567           somhex(8) = sa3a4
 568           somhex(5) = sa4a1
 569         else
 570           somhex(6) = sa4a1
 571           somhex(7) = sa3a4
 572           somhex(8) = sa2a3
 573           somhex(5) = sa1a2
 574         endif
 575 #ifdef _DEBUG_HOMARD_
 576           if ( larete.eq.-8 ) then
 577       write (ulsort,90002)'sommets quad',sa1a2, sa2a3, sa3a4, sa4a1
 578       write (ulsort,90002)'sommets hexa  5-8',(somhex(jaux),jaux=5,8)
 579       write (ulsort,90002)'aretes hexa  9-12',(arehex(jaux),jaux=9,12)
 580             endif
 581 #endif
 582 c
 583 c 2.6.3. ==> Face 2 : par definition de l'hexa, elle s'appuie sur a1.
 584 c   Par construction, quajoi(1) borde le 1er joint, donc f2=quajoi(1).
 585 c   Par construction, l'arete dupliquee est la 1ere et la 3eme
 586 c   du quadrangle (cf. mmag31), donc :
 587 c   Les aretes 1 et 3 du quadrangle peuvent etre a5 ou a6
 588 c   Les aretes 2 et 4 du quadrangle peuvent etre a1 ou a9
 589 c   Si (a1,a6,a9,a5) de l'hexaedre = (a4,a1,a2,a3) du quad : code = 2
 590 c   Si (a1,a6,a9,a5) de l'hexaedre = (a2,a1,a4,a3) du quad : code = 6
 591 c   Si (a1,a6,a9,a5) de l'hexaedre = (a4,a3,a2,a1) du quad : code = 8
 592 c   Si (a1,a6,a9,a5) de l'hexaedre = (a2,a3,a4,a1) du quad : code = 4
 593 c
 594         quahex(indhex,2) = quajoi(1)
 595         a1 = arequa(quajoi(1),1)
 596         a2 = arequa(quajoi(1),2)
 597         a3 = arequa(quajoi(1),3)
 598         a4 = arequa(quajoi(1),4)
 599 cgn      write (ulsort,90002) 'aretes de fac 2 1/6/9/5',
 600 cgn     >                     arehex(1),arehex(6), arehex(9), arehex(5)
 601         call utsoqu ( somare, a1, a2, a3, a4,
 602      >                sa1a2, sa2a3, sa3a4, sa4a1 )
 603 cgn      write (ulsort,90002) 'aretes de qua 1', a1, a2, a3, a4
 604 cgn      write (ulsort,90002) 'sommet de qua 1', sa1a2, sa2a3, sa3a4, sa4a1
 605         if ( sa1a2.eq.somhex(1) .or. sa1a2.eq.somhex(6) ) then
 606           arehex(5) = a1
 607           arehex(6) = a3
 608         elseif ( sa1a2.eq.somhex(2) .or. sa1a2.eq.somhex(5) ) then
 609           arehex(5) = a3
 610           arehex(6) = a1
 611         else
 612           write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete
 613           write (ulsort,texte(langue,16)) mess14(langue,1,6), indhex, 0
 614           write (ulsort,texte(langue,32)) nujoin - nbjoin
 615           write (ulsort,texte(langue,39)) nujois
 616 cgn      write (ulsort,90002) 'aretes de fac 1 1/2/3',
 617 cgn     >                     arehex(1),arehex(2), arehex(3)
 618 cgn      write (ulsort,90002) 'aretes de fac 1 4/5/6',
 619 cgn     >                     arehex(4),arehex(5), arehex(6)
 620 cgn      write (ulsort,90002) 'aretes de fac 3 1/9/4/7',
 621 cgn     >                     arehex(1),    0  , arehex(4), 0
 622 cgn      write (ulsort,90002) 'aretes de qua 1 1/2/3/4', a1, a2, a3, a4
 623 cgn      write (ulsort,90002) 'sommet de fac 3 1/3/6/4',
 624 cgn     >                     somhex(1),somhex(3), somhex(6), somhex(4)
 625 cgn      write (ulsort,90002) 'aretes de qua 1 1/2/3/4', a1, a2, a3, a4
 626 cgn      write (ulsort,90002) 'sommet de qua 1 ',
 627 cgn     >                         sa1a2, sa2a3, sa3a4, sa4a1
 628           codret = 263
 629           goto 5555
 630         endif
 631 cgn      write (ulsort,90002) 'arehex(5), arehex(6)',arehex(5), arehex(6)
 632         if ( arehex(6).eq.a1 ) then
 633           if ( arehex(1).eq.a4 ) then
 634             coquhe(indhex,2) = 2
 635           else
 636             coquhe(indhex,2) = 6
 637           endif
 638         else
 639 c   La face f3 est le quadrangle quajoi(2).
 640           if ( arehex(1).eq.a4 ) then
 641             coquhe(indhex,2) = 8
 642           else
 643             coquhe(indhex,2) = 4
 644           endif
 645         endif
 646 #ifdef _DEBUG_HOMARD_
 647           if ( larete.eq.-8 ) then
 648       write (ulsort,90002)'aretes hexa 5-6',(arehex(jaux),jaux=5,6)
 649             endif
 650 #endif
 651 c
 652 c 2.6.4. ==> Face 3 : par definition de l'hexa, elle s'appuie sur a2.
 653 c   Par construction, f3=quajoi(du 2eme dans l'ordre entrant).
 654 c   Par construction, l'arete dupliquee est la 1ere et la 3eme
 655 c   du quadrangle (cf. mmag31), donc :
 656 c   Les aretes 1 et 3 du quadrangle peuvent etre a5 ou a7
 657 c   Les aretes 2 et 4 du quadrangle peuvent etre a2 ou a10
 658 c   Si (a2,a5,a10,a7) de l'hexaedre = (a4,a1,a2,a3) du quad : code = 2
 659 c   Si (a2,a5,a10,a7) de l'hexaedre = (a2,a1,a4,a3) du quad : code = 6
 660 c   Si (a2,a5,a10,a7) de l'hexaedre = (a4,a3,a2,a1) du quad : code = 8
 661 c   Si (a2,a5,a10,a7) de l'hexaedre = (a2,a3,a4,a1) du quad : code = 4
 662 c
 663         quahex(indhex,3) = quajoi(nujolo(2))
 664 cgn      write (ulsort,90002) 'quadrangle de F3', qua(2)
 665 cgn      write (ulsort,90002) 'aretes de qua 1/2/3/4',
 666 cgn     > arequa(qua(2),1),arequa(qua(2),2),
 667 cgn     > arequa(qua(2),3),arequa(qua(2),4)
 668         if ( arehex(5).eq.arequa(quajoi(nujolo(2)),1) ) then
 669           if ( arehex(2).eq.arequa(quajoi(nujolo(2)),4) ) then
 670             coquhe(indhex,3) = 2
 671           else
 672             coquhe(indhex,3) = 6
 673           endif
 674         else
 675           if ( arehex(2).eq.arequa(quajoi(nujolo(2)),4) ) then
 676             coquhe(indhex,3) = 8
 677           else
 678             coquhe(indhex,3) = 4
 679           endif
 680         endif
 681 cgn      write (ulsort,1001) 'aretes de fac 3 2/5/10/7',
 682 cgn     >                     arehex(2),arehex(5), arehex(10), arehex(7)
 683 c
 684 c 2.6.5. ==> Face 4 : par definition de l'hexa, elle s'appuie sur a3.
 685 c   Par construction, f4=quajoi(du 4eme dans l'ordre entrant).
 686 c   Les aretes 1 et 3 du quadrangle peuvent etre a8 ou a6
 687 c   Les aretes 2 et 4 du quadrangle peuvent etre a3 ou a11
 688 c   Si (a3,a8,a11,a6) de l'hexaedre = (a4,a1,a2,a3) du quad : code = 2
 689 c   Si (a3,a8,a11,a6) de l'hexaedre = (a2,a1,a4,a3) du quad : code = 6
 690 c   Si (a3,a8,a11,a6) de l'hexaedre = (a4,a3,a2,a1) du quad : code = 8
 691 c   Si (a3,a8,a11,a6) de l'hexaedre = (a2,a3,a4,a1) du quad : code = 4
 692 c
 693         quahex(indhex,4) = quajoi(nujolo(4))
 694 cgn      write (ulsort,90002) 'quadrangle de F4', qua(2)
 695 cgn      write (ulsort,90002) 'aretes de qua 1/2/3/4',
 696 cgn     > arequa(qua(3),1),arequa(qua(3),2),
 697 cgn     > arequa(qua(3),3),arequa(qua(3),4)
 698         if ( arehex(6).eq.arequa(quajoi(nujolo(4)),3) ) then
 699           if ( arehex(3).eq.arequa(quajoi(nujolo(4)),4) ) then
 700             coquhe(indhex,4) = 2
 701           else
 702             coquhe(indhex,4) = 6
 703           endif
 704           arehex(8) = arequa(quajoi(nujolo(4)),1)
 705         else
 706           if ( arehex(3).eq.arequa(quajoi(nujolo(4)),4) ) then
 707             coquhe(indhex,4) = 8
 708           else
 709             coquhe(indhex,4) = 4
 710           endif
 711           arehex(8) = arequa(quajoi(nujolo(4)),3)
 712         endif
 713 c
 714 c 2.6.6. ==> Face 5 : par definition de l'hexa, elle s'appuie sur a4.
 715 c   Par construction, f5=quajoi(du 3eme dans l'ordre entrant).
 716 c   Les aretes 1 et 3 du quadrangle peuvent etre a7 ou a8
 717 c   Les aretes 2 et 4 du quadrangle peuvent etre a4 ou a12
 718 c   Si (a4,a7,a12,a8) de l'hexaedre = (a4,a1,a2,a3) du quad : code = 2
 719 c   Si (a4,a7,a12,a8) de l'hexaedre = (a2,a1,a4,a3) du quad : code = 6
 720 c   Si (a4,a7,a12,a8) de l'hexaedre = (a4,a3,a2,a1) du quad : code = 8
 721 c   Si (a4,a7,a12,a8) de l'hexaedre = (a2,a3,a4,a1) du quad : code = 4
 722 c
 723         quahex(indhex,5) = quajoi(nujolo(3))
 724 cgn      write (ulsort,90002) 'quadrangle de F5', qua(2)
 725 cgn      write (ulsort,90002) 'aretes de qua 1/2/3/4',
 726 cgn     > arequa(qua(4),1),arequa(qua(4),2),
 727 cgn     > arequa(qua(4),3),arequa(qua(4),4)
 728         if ( arehex(8).eq.arequa(quajoi(nujolo(3)),3) ) then
 729           if ( arehex(4).eq.arequa(quajoi(nujolo(3)),4) ) then
 730             coquhe(indhex,5) = 2
 731           else
 732             coquhe(indhex,5) = 6
 733           endif
 734         else
 735           if ( arehex(4).eq.arequa(quajoi(nujolo(3)),4) ) then
 736             coquhe(indhex,5) = 8
 737           else
 738             coquhe(indhex,5) = 4
 739           endif
 740         endif
 741 c
 742 c 2.6.8.==> nujoin est le numero du joint parmi tous les joints.
 743 c       Il faut retrancher le nombre de joints de pentaedres qui
 744 c       ont ete crees auparavant
 745 c       Il faut ajouter 1 pour tenir compte de la famille libre.
 746 c
 747         famhex(indhex) = nujoin - nbjoin + 1
 748 c
 749         hethex(indhex)  = 0
 750         filhex(indhex)  = 0
 751         perhex(indhex)  = 0
 752 c
 753 #ifdef _DEBUG_HOMARD_
 754         if ( indhex.eq.-1 ) then
 755       write (ulsort,texte(langue,16)) mess14(langue,1,6), indhex, 0
 756       write (ulsort,90002)'faces ',(quahex(indhex,jaux),jaux=1,6)
 757       write (ulsort,90002)'coquhe',(coquhe(indhex,jaux),jaux=1,6)
 758       write (ulsort,90002)'aretes 1-4',(arehex(jaux),jaux=1,4)
 759       write (ulsort,90002)'aretes 5-8',(arehex(jaux),jaux=5,8)
 760       write (ulsort,90002)'aretes 9-12',(arehex(jaux),jaux=9,12)
 761       write (ulsort,90002)'sommets 1-4', (somhex(jaux),jaux=1,4)
 762       write (ulsort,90002)'sommets 5-8', (somhex(jaux),jaux=5,8)
 763         endif
 764 #endif
 765 c
 766     2 continue
 767 c
 768 c====
 769 c 5. la fin
 770 c====
 771 c
 772  5555 continue
 773 c
 774       if ( codret.ne.0 ) then
 775 c
 776 #include "envex2.h"
 777 c
 778       write (ulsort,texte(langue,1)) 'Sortie', nompro
 779       write (ulsort,texte(langue,2)) codret
 780 c
 781       endif
 782 c
 783 #ifdef _DEBUG_HOMARD_
 784       write (ulsort,texte(langue,1)) 'Sortie', nompro
 785       call dmflsh (iaux)
 786 #endif
 787 c
 788       end