src/tool/Modification/mmag32.F

   1       subroutine mmag32 ( indpen,
   2      >                    nbduno, nbduar,
   3      >                    nbpejt, nbvojm, nbjoto,
   4      >                    tbaux2, tbau30, tbau40,
   5      >                    tbau41,
   6      >                    nbte06, tbau51,
   7      >                    nbpe09, tbau52,
   8      >                    coonoe, somare,
   9      >                    aretri, hettri,
  10      >                    filtri, pertri, nivtri,
  11      >                    arequa,
  12      >                    facpen, cofape,
  13      >                    hetpen, filpen, perpen,
  14      >                    famtri, fampen,
  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.2
  37 c    -               -          --              - -
  38 c    Creation des mailles pour les joints triples :
  39 c    . pentaedres
  40 c    Et donc des triangles supplementaires
  41 c ______________________________________________________________________
  42 c .        .     .        .                                            .
  43 c .  nom   . e/s . taille .           description                      .
  44 c .____________________________________________________________________.
  45 c . indpen . es  .   1    . indice du dernier pentaedre 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 . nbvojm . e   .   1    . nombre de volumes de joints multiples      .
  50 c . nbjoto . e   .   1    . nombre total de joints                     .
  51 c . tbaux2 . e   .4*nbjoto. Pour le i-eme joint :                      .
  52 c .        .     .        . Numeros des familles MED des volumes       .
  53 c .        .     .        . jouxtant le pentaedre/hexaedre, classes du .
  54 c .        .     .        . plus petit (1,i) au plus grand             .
  55 c .        .     .        . 0, si pas de volume voisin                 .
  56 c . tbau30 . e   .8*nbduno. Pour la i-eme duplication de noeud :       .
  57 c .        .     .        . (1,i) : noeud a dupliquer                  .
  58 c .        .     .        . (2,i) : arete construite sur le noeud      .
  59 c .        .     .        . (3,i) : noeud cree cote min(fammed)        .
  60 c .        .     .        . (4,i) : noeud cree cote max(fammed)        .
  61 c .        .     .        . (5,i) : numero du joint simple cree        .
  62 c .        .     .        . (6,i) : arete entrant dans le cote 1       .
  63 c .        .     .        . (7,i) : arete entrant dans le cote 2       .
  64 c .        .     .        . (8,i) : ordre de multiplicite              .
  65 c . tbau40 . e   .6*nbduar. Pour la i-eme duplication d'arete :        .
  66 c .        .     .        . (1,i) : arete a dupliquer                  .
  67 c .        .     .        . (2,i) : arete creee cote min(fammed)       .
  68 c .        .     .        . (3,i) : arete creee cote max(fammed)       .
  69 c .        .     .        . (4,i) : numero du joint simple cree        .
  70 c .        .     .        . (5,i) : ordre de multiplicite              .
  71 c .        .     .        . (6,i) : arete d'orientation de joint       .
  72 c . tbau41 . e   .4*nbvojm. Les pentaedres de joint triple, puis les   .
  73 c .        .     .        . hexaedres de joint quadruple :             .
  74 c .        .     .        . (1,i) : arete multiple                     .
  75 c .        .     .        . (2,i) : numero du joint                    .
  76 c .        .     .        . Pour le i-eme pentaedre de joint triple :  .
  77 c .        .     .        . (3,i) : triangle cree cote 1er sommet      .
  78 c .        .     .        . (4,i) : triangle cree cote 2nd sommet      .
  79 c .        .     .        . Pour le i-eme hexaedre de joint quadruple :.
  80 c .        .     .        . (3,i) : quadrangle cree cote 1er sommet    .
  81 c .        .     .        . (4,i) : quadrangle cree cote 2nd sommet    .
  82 c . nbte06 . e   .   1    . nombre de tetr. des j. ponctuels d'ordre 6 .
  83 c . tbau51 . es  .9*nbte06. Les tetraedres ponctuels entre les joints  .
  84 c .        .     .        . triples :                                  .
  85 c .        .     .        . (1,i) : noeud multiple                     .
  86 c .        .     .        . (2,i) : triangle cote du 1er joint triple  .
  87 c .        .     .        . (3,i) : triangle cote du 2eme joint triple .
  88 c .        .     .        . (4,i) : triangle cote du 3eme joint triple .
  89 c .        .     .        . (5,i) : triangle cote du 4eme joint triple .
  90 c .        .     .        . (1+k) : pour le k-eme triangle, 1 s'il     .
  91 c .        .     .        . entre dans le joint ponctuel, -1 sinon     .
  92 c . nbpe09 . e   .   1    . nombre de pent. des j. ponctuels d'ordre 9 .
  93 c . tbau52 . es  .  11*   . Les pentaedres ponctuels entre les joints  .
  94 c .        .     . nbpe09 . triples et quadruples :                    .
  95 c .        .     .        . (1,i) : noeud multiple                     .
  96 c .        .     .        . (2,i) : triangle cote du 1er joint triple  .
  97 c .        .     .        . (3,i) : triangle cote du 2eme joint triple .
  98 c .        .     .        . (4,i) : quadrangle cote du 1er joint quad. .
  99 c .        .     .        . (5,i) : quadrangle cote du 2eme joint quad..
 100 c .        .     .        . (6,i) : quadrangle cote du 3eme joint quad..
 101 c .        .     .        . (1+k) : pour la k-eme face, 1 si elle      .
 102 c .        .     .        . entre dans le joint ponctuel, -1 sinon     .
 103 c . coonoe . e   .nbnoto*3. coordonnees des noeuds                     .
 104 c . somare . es  .2*nbarto. numeros des extremites d'arete             .
 105 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
 106 c . hettri . es  . nbtrto . historique de l'etat des triangles         .
 107 c . filtri . es  . nbtrto . premier fils des triangles                 .
 108 c . pertri . es  . nbtrto . pere des triangles                         .
 109 c . nivtri . es  . nbtrto . niveau des triangles                       .
 110 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
 111 c . facpen . es  .nbpecf*5. numeros des 5 faces des pentaedres         .
 112 c . cofape . es  .nbpecf*5. code des 5 faces des pentaedres            .
 113 c . hetpen . es  . nbpeto . historique de l'etat des pentaedres        .
 114 c . filpen . es  . nbpeto . premier fils des pentaedres                .
 115 c . perpen . es  . nbpeto . pere des pentaedres                        .
 116 c . famtri . es  . nbtrto . famille des triangles                      .
 117 c . fampen . es  . nbpeto . famille des pentaedres                     .
 118 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 119 c . langue . e   .    1   . langue des messages                        .
 120 c .        .     .        . 1 : francais, 2 : anglais                  .
 121 c . codret . es  .    1   . code de retour des modules                 .
 122 c .        .     .        . 0 : pas de probleme                        .
 123 c ______________________________________________________________________
 124 c
 125 c====
 126 c 0. declarations et dimensionnement
 127 c====
 128 c
 129 c 0.1. ==> generalites
 130 c
 131       implicit none
 132       save
 133 c
 134       character*6 nompro
 135       parameter ( nompro = 'MMAG32' )
 136 c
 137 #include "nblang.h"
 138 c
 139       integer ordre
 140       parameter ( ordre = 3 )
 141 c
 142 c 0.2. ==> communs
 143 c
 144 #include "envex1.h"
 145 c
 146 #include "envca1.h"
 147 #include "nombno.h"
 148 #include "nombar.h"
 149 #include "nombtr.h"
 150 #include "nombqu.h"
 151 #include "nombpe.h"
 152 #include "impr02.h"
 153 c
 154 c 0.3. ==> arguments
 155 c
 156       integer indpen
 157       integer nbduno, nbduar
 158       integer nbpejt, nbvojm, nbjoto
 159       integer tbaux2(4,nbjoto)
 160       integer tbau30(8,nbduno), tbau40(6,nbduar)
 161       integer tbau41(4,nbvojm)
 162       integer nbte06, tbau51(9,nbte06)
 163       integer nbpe09, tbau52(11,nbpe09)
 164       integer somare(2,nbarto)
 165       integer aretri(nbtrto,3), hettri(nbtrto)
 166       integer filtri(nbtrto), pertri(nbtrto), nivtri(nbtrto)
 167       integer arequa(nbquto,4)
 168       integer facpen(nbpecf,5), cofape(nbpecf,5)
 169       integer hetpen(nbpeto), filpen(nbpeto), perpen(nbpeto)
 170       integer famtri(nbtrto), fampen(nbpeto)
 171 c
 172       double precision coonoe(nbnoto,sdim)
 173 c
 174       integer ulsort, langue, codret
 175 c
 176 c 0.4. ==> variables locales
 177 c
 178       integer iaux, jaux, kaux, laux
 179       integer larete
 180       integer letria(2), lequad
 181 c
 182       integer nujoin, nujois(ordre)
 183       integer aredup(2*ordre)
 184       integer arejoi(ordre), quajoi(ordre)
 185       integer nujolo(ordre)
 186       integer a1, a2, a3, a4
 187       integer sa1a2, sa2a3, sa3a4, sa4a1, sa3a1
 188       integer sompen(6), arepen(9), orient
 189       integer tabcod(6)
 190 c
 191       integer nbmess
 192       parameter ( nbmess = 40 )
 193       character*80 texte(nblang,nbmess)
 194 c
 195 c 0.5. ==> initialisations
 196 c ______________________________________________________________________
 197 c
 198       data tabcod / 4, 5, 6, 1, 2, 3 /
 199 c
 200 c====
 201 c 1. initialisations
 202 c====
 203 c 1.1. ==> messages
 204 c
 205 #include "impr01.h"
 206 c
 207 #ifdef _DEBUG_HOMARD_
 208       write (ulsort,texte(langue,1)) 'Entree', nompro
 209       call dmflsh (iaux)
 210 #endif
 211 c
 212 #include "impr03.h"
 213 #include "mmag01.h"
 214 #include "mmag02.h"
 215 c
 216 #ifdef _DEBUG_HOMARD_
 217       write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpejt
 218       write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno
 219       write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar
 220 #endif
 221 c
 222       codret = 0
 223 c
 224 cgn      write(ulsort,1001) 'nbnoto, nbarto, nbtrto',nbnoto, nbarto,nbtrto
 225 cgn      write(ulsort,1001) 'nbpejt',nbpejt
 226 cgn      write(ulsort,1000) (iaux,iaux=1,20)
 227 cgn      write(ulsort,1001) 'tbaux2',4,nbjoto
 228 cgn      do 1101 , kaux = 1,nbjoto
 229 cgn       write(ulsort,1000) (tbaux2(jaux,kaux),jaux=1,4)
 230 cgn 1101 continue
 231 cgn      write(ulsort,1001) 'tbau41',4,nbvojm
 232 cgn      do 1102 , kaux = 1,nbvojm
 233 cgn       write(ulsort,1000) (tbau41(jaux,kaux),jaux=1,4)
 234 cgn 1102  continue
 235 cgn 1000 format(10i9)
 236 cgn 1001 format(a,4i6)
 237 c
 238 c====
 239 c 2. Parcours des aretes triples / pentaedres de joint triple
 240 c====
 241 #ifdef _DEBUG_HOMARD_
 242       write (ulsort,texte(langue,5)) mess14(langue,3,1)
 243 #endif
 244 c
 245 c  Le long de l'arete triple :
 246 c  Le triangle (a1,a2,a3) est defini du cote du 1er sommet
 247 c     a1 est du cote du 1er joint simple voisin
 248 c     a2 est du cote du 2eme joint simple voisin
 249 c     a3 est du cote du 3eme joint simple voisin
 250 c  Le triangle (a4,a5,a6) est defini du cote du 2nd sommet
 251 c     a4 est du cote du 1er joint simple voisin
 252 c     a5 est du cote du 2eme joint simple voisin
 253 c     a6 est du cote du 3eme joint simple voisin
 254 c  L'arete triple se retrouve dans a7, a8, a9.
 255 c
 256 c    S3=tbau30(3,i/St3)       arepen(9)          S6=tbau30(4,i/St3)
 257 c           x------------------------------------------x
 258 c          .                                          .
 259 c         .  .                                       .  .
 260 c   arepen(3)                                  arepen(6)
 261 c       .     .                                    .     .
 262 c      .                                          .
 263 c     .        .arepen(1)                        .        . arepen(4)
 264 c    .                                          .
 265 c S2.           .          arepen(8)         S5.=tbau30(4,i/St2)
 266 c  x - - - - - - - - - - - - - - - - - - - - -x
 267 ctbau30(3,i/St2).                               .           .
 268 c          .                                          .
 269 c       arepen(2)                                arepen(5).  .
 270 c                  x------------------------------------------x
 271 c       S1=tbau30(3,i/St1)          arepen(7)        S4=tbau30(4,i/St1)
 272 c
 273 c voir utarpe pour le croquis ci-dessus
 274 c
 275       do 2 , iaux = 1 , nbpejt
 276 c
 277         indpen = indpen + 1
 278 c
 279         larete = tbau41(1,iaux)
 280 c
 281         nujoin = tbau41(2,iaux)
 282 c
 283 #ifdef _DEBUG_HOMARD_
 284           if ( larete.eq.-8 ) then
 285       write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete
 286       write (ulsort,texte(langue,31)) nujoin
 287               endif
 288 #endif
 289 c
 290 c 2.1. ==> reperage des numeros des 3 joints simples voisins
 291 c
 292         do 21 , jaux = 1 , ordre
 293           nujois(jaux) = tbaux2(jaux,nujoin)
 294    21   continue
 295 #ifdef _DEBUG_HOMARD_
 296         if ( larete.eq.-8 ) then
 297         write (ulsort,texte(langue,39)) nujois
 298         endif
 299 #endif
 300 c
 301 c 2.2. ==> Reperage des aretes qui partent de chacun des noeuds.
 302 C          Elles delimitent les faces 1 et 2 du pentaedre en cours.
 303 c
 304 #ifdef _DEBUG_HOMARD_
 305       write (ulsort,texte(langue,3)) 'MMAG91', nompro
 306 #endif
 307         call mmag91 ( larete, ordre, nujois,
 308      >                nbduno, tbau30,
 309      >                somare,
 310      >                aredup,
 311      >                ulsort, langue, codret )
 312 c
 313         if ( codret.ne.0 ) then
 314         write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, 0
 315         write (ulsort,texte(langue,31)) nujoin
 316         goto 5555
 317         endif
 318 c
 319 c 2.3. ==> Reperage des aretes et des quadrangles batis sur les joints
 320 c
 321 #ifdef _DEBUG_HOMARD_
 322       write (ulsort,texte(langue,3)) 'MMAG92', nompro
 323 #endif
 324         call mmag92 ( larete, ordre, nujois,
 325      >                nbduar, tbau40,
 326      >                arejoi, quajoi,
 327      >                ulsort, langue, codret )
 328 c
 329         if ( codret.ne.0 ) then
 330         write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, 0
 331         write (ulsort,texte(langue,31)) nujoin
 332         goto 5555
 333         endif
 334 c
 335 #ifdef _DEBUG_HOMARD_
 336           if ( larete.eq.-8 ) then
 337         do 23111 , jaux = 1 , ordre
 338         write (ulsort,90015)'Joint',jaux,', quadrangle',quajoi(jaux)
 339         write (ulsort,90015)'arete de joints',arejoi(jaux),
 340      >   ', de sommets',somare(1,arejoi(jaux)),somare(2,arejoi(jaux))
 341 23111   continue
 342           endif
 343 #endif
 344 c
 345 c 2.4. ==> Determination de l'orientation des joints
 346 c          Par hypothese, la face f3 du pentaedre s'appuie sur le 1er
 347 c          joint simple. Ensuite, par definition du pentaedre, les
 348 c          faces f4 et f5 arrivent dans le sens positif quand on
 349 c          entre dans le pentaedre depuis la face f1.
 350 c          On cherche donc le positionnement des 3 joints relativement
 351 c          a l'arete dupliquee et on en deduit l'ordre d'apparition
 352 c          des joints qui creeront les faces f4 et f5.
 353 c
 354 #ifdef _DEBUG_HOMARD_
 355       write (ulsort,texte(langue,3)) 'UTORA3', nompro
 356 #endif
 357         call utora3 ( orient,
 358      >                larete,
 359      >                arejoi(1), arejoi(2), arejoi(3),
 360      >                coonoe, somare,
 361      >                ulsort, langue, codret )
 362 #ifdef _DEBUG_HOMARD_
 363       if ( larete.eq.-8 ) then
 364       write (ulsort,90002)'orient',orient
 365       endif
 366 #endif
 367 c
 368         nujolo(1) = 1
 369         if ( orient.gt.0 ) then
 370           nujolo(2) = 2
 371           nujolo(3) = 3
 372         else
 373           nujolo(2) = 3
 374           nujolo(3) = 2
 375         endif
 376 c
 377 c 2.5. ==> Creation des triangles
 378 c          Eventuellement, on recree plusieurs fois le meme triangle.
 379 c          Pas grave car il est toujours cree en s'orientant sur les
 380 c          joints simples adjacents.
 381 c
 382         do 25 , jaux = 1 , 2
 383 c
 384 c 2.5.1. ==> Numero du triangle
 385 c
 386           kaux = tbau41(2+jaux,iaux)
 387 c
 388 #ifdef _DEBUG_HOMARD_
 389           if ( larete.eq.-8 ) then
 390       write (ulsort,texte(langue,16)) mess14(langue,1,2), kaux,
 391      > jaux
 392        write (ulsort,texte(langue,17))
 393      > (aredup(kaux),kaux=ordre*(jaux-1)+1,ordre*jaux)
 394            endif
 395 #endif
 396 c
 397 c 2.5.2. ==> Aretes
 398 c          La 1ere arete est celle jouxtant le 1er joint simple.
 399 c          La 2eme arete est celle jouxtant le 2eme joint simple.
 400 c          La 3eme arete est la derniere.
 401 c
 402           aretri(kaux,1) = aredup(ordre*jaux-2)
 403           aretri(kaux,2) = aredup(ordre*jaux-1)
 404           aretri(kaux,3) = aredup(ordre*jaux)
 405 c
 406 c 2.5.3. ==> Caracteristiques
 407 c
 408           famtri(kaux) = 1
 409 c
 410           hettri(kaux) = 0
 411           filtri(kaux) = 0
 412           pertri(kaux) = 0
 413           nivtri(kaux) = 0
 414 c
 415           letria(jaux) = kaux
 416 c
 417 c 2.5.4. ==> Impact pour l'eventuel joint ponctuel voisin
 418 c            Pour le 1er triangle :
 419 c            . Si l'orientation est positive, le triangle entre dans le
 420 c              pentaedre, donc sort de l'eventuel joint ponctuel
 421 c              voisin : -1 = 2*1 - 3
 422 c            . Sinon, le triangle sort du pentaedre, donc entre dans
 423 c              l'eventuel joint ponctuel voisin : 1 = 3 - 2*1
 424 c            Pour le 2nd triangle : raisonnement symetrique
 425 c            . Orientation >0, entree :  1 = 2*2 - 3
 426 c            . Orientation <0, sortie : -1 = 3 - 2*2
 427 c
 428           if ( orient.gt.0 ) then
 429             laux = 2*jaux - 3
 430           else
 431             laux = 3 - 2*jaux
 432           endif
 433 c
 434 #ifdef _DEBUG_HOMARD_
 435       write (ulsort,texte(langue,3)) 'MMAG93', nompro
 436 #endif
 437           call mmag93 ( kaux, laux,
 438      >                  nbte06, tbau51,
 439      >                  nbpe09, tbau52,
 440      >                  ulsort, langue, codret )
 441 c
 442    25   continue
 443 c
 444 c 2.6. ==> Creation du pentaedre
 445 c
 446 #ifdef _DEBUG_HOMARD_
 447       write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, 0
 448 #endif
 449 c
 450 c 2.6.1. ==> Face 1 : c'est le triangle cree du cote du debut de
 451 c                     l'arete triple
 452 c   On impose :
 453 c     la 1ere arete du pentaedre est la 1ere arete du triangle ;
 454 c   --> le code sera donc 1 ou 4.
 455 c   Si l'orientation est positive, le triangle entre dans le pentaedre.
 456 c   On lui donnera donc le code 1.
 457 C   Inversement, si l'orientation est negative, il va sortir
 458 c   du pentaedre. On lui donnera alors le code 4.
 459 c
 460 c   Avec utsotr, on recupere les sommets du triangle dans l'ordre de
 461 c   ses aretes. On en deduit les 3 premiers sommets du pentaedre selon
 462 c   le positionnement du triangle.
 463 c
 464         facpen(indpen,1) = letria(1)
 465         if ( orient.gt.0 ) then
 466           cofape(indpen,1) = 1
 467         else
 468           cofape(indpen,1) = 4
 469         endif
 470 c
 471         call utsotr ( somare, aredup(1), aredup(2), aredup(3),
 472      >                sa1a2, sa2a3, sa3a1 )
 473         arepen(1) = aredup(1)
 474         if ( orient.gt.0 ) then
 475           arepen(2) = aredup(2)
 476           arepen(3) = aredup(3)
 477           sompen(1) = sa1a2
 478           sompen(3) = sa3a1
 479         else
 480           arepen(2) = aredup(3)
 481           arepen(3) = aredup(2)
 482           sompen(1) = sa3a1
 483           sompen(3) = sa1a2
 484         endif
 485         sompen(2) = sa2a3
 486 #ifdef _DEBUG_HOMARD_
 487           if ( larete.eq.-8 ) then
 488       write (ulsort,90002)'sommets tria',sa1a2, sa2a3, sa3a1
 489       write (ulsort,90002)'sommets penta 1-3',(sompen(jaux),jaux=1,3)
 490       write (ulsort,90002)'aretes penta  1-3',(arepen(jaux),jaux=1,3)
 491             endif
 492 #endif
 493 c
 494 c 2.6.2. ==> Face 2 : c'est le 2nd triangle cree, du cote de la fin
 495 c                     de l'arete triple.
 496 c   Suite aux choix faits sur f1, sa 1ere arete est a4.
 497 c   Si le code du triangle en tant que face 1 est 1, alors sa 2eme arete
 498 c   est la translatee de a2, donc a5, ce qui fait un code 4.
 499 c   Si le code du triangle en tant que face 1 est 4, alors sa 2eme arete
 500 c   est la translatee de a3, donc a5, ce qui fait un code 1.
 501 c
 502         facpen(indpen,2) = letria(2)
 503         cofape(indpen,2) = tabcod(cofape(indpen,1))
 504 c
 505         call utsotr ( somare, aredup(4), aredup(5), aredup(6),
 506      >                sa1a2, sa2a3, sa3a1 )
 507         arepen(4) = aredup(4)
 508         if ( orient.gt.0 ) then
 509           arepen(5) = aredup(5)
 510           arepen(6) = aredup(6)
 511           sompen(4) = sa1a2
 512           sompen(6) = sa3a1
 513         else
 514           arepen(5) = aredup(6)
 515           arepen(6) = aredup(5)
 516           sompen(4) = sa3a1
 517           sompen(6) = sa1a2
 518         endif
 519         sompen(5) = sa2a3
 520 #ifdef _DEBUG_HOMARD_
 521           if ( larete.eq.-8 ) then
 522       write (ulsort,90002)'sommets tria',sa1a2, sa2a3, sa3a1
 523       write (ulsort,90002)'sommets penta 4-6',(sompen(jaux),jaux=4,6)
 524       write (ulsort,90002)'aretes penta  4-6',(arepen(jaux),jaux=4,6)
 525             endif
 526 #endif
 527 c
 528 c 2.6.3. ==> Face 3 : par definition du pentaedre, elle s'appuie sur a1.
 529 c   Par construction, quajoi(1) borde le 1er joint, donc f3=quajoi(1)
 530 c   Par construction, l'arete dupliquee est la 1ere et la 3eme du
 531 c   quadrangle (mmag31), donc il y a 4 possibilites de positionnement :
 532 c     Si (a1,a9,a4,a7) du pentaedre = (a4,a1,a2,a3) du quad : code = 2
 533 c     Si (a1,a9,a4,a7) du pentaedre = (a2,a1,a4,a3) du quad : code = 6
 534 c     Si (a1,a9,a4,a7) du pentaedre = (a4,a3,a2,a1) du quad : code = 8
 535 c     Si (a1,a9,a4,a7) du pentaedre = (a2,a3,a4,a1) du quad : code = 4
 536 c  On va positionner le tout en recherchant les extremites de l'arete
 537 c  dupliquee et en les comparant aux sommets du pentaedre
 538 c
 539         facpen(indpen,3) = quajoi(1)
 540         a1 = arequa(quajoi(1),1)
 541         a2 = arequa(quajoi(1),2)
 542         a3 = arequa(quajoi(1),3)
 543         a4 = arequa(quajoi(1),4)
 544 cgn      write (ulsort,90002) 'aretes de fac 3 1/9/4/7',
 545 cgn     >                     arepen(1),arepen(9), arepen(4), arepen(7)
 546         call utsoqu ( somare, a1, a2, a3, a4,
 547      >                sa1a2, sa2a3, sa3a4, sa4a1 )
 548 cgn      write (ulsort,90002) 'aretes de qua 1', a1, a2, a3, a4
 549 cgn      write (ulsort,90002) 'sommet de qua 1', sa1a2, sa2a3, sa3a4, sa4a1
 550 c
 551         if ( sa1a2.eq.sompen(1) .or. sa1a2.eq.sompen(4) ) then
 552           arepen(7) = a1
 553           arepen(9) = a3
 554         elseif ( sa1a2.eq.sompen(3) .or. sa1a2.eq.sompen(6) ) then
 555           arepen(7) = a3
 556           arepen(9) = a1
 557         else
 558           write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete
 559           write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, 0
 560           write (ulsort,texte(langue,31)) nujoin
 561           write (ulsort,texte(langue,39)) nujois
 562 cgn      write (ulsort,90002) 'aretes de fac 1 1/2/3',
 563 cgn     >                     aredup(1),aredup(2), aredup(3)
 564 cgn      write (ulsort,90002) 'aretes de fac 1 4/5/6',
 565 cgn     >                     aredup(4),aredup(5), aredup(6)
 566 cgn      write (ulsort,90002) 'aretes de fac 3 1/9/4/7',
 567 cgn     >                     aredup(1),    0  , aredup(4), 0
 568 cgn      write (ulsort,90002) 'aretes de qua 1 1/2/3/4', a1, a2, a3, a4
 569 cgn      write (ulsort,90002) 'aretes de qua 1 1/2/3/4', a1, a2, a3, a4
 570 cgn      write (ulsort,90002) 'sommet de qua 1 ',
 571 cgn     >                         sa1a2, sa2a3, sa3a4, sa4a1
 572           codret = 263
 573           goto 5555
 574         endif
 575 c
 576         if ( arepen(9).eq.a1 ) then
 577           if ( arepen(1).eq.a4 ) then
 578             cofape(indpen,3) = 2
 579           else
 580             cofape(indpen,3) = 6
 581           endif
 582         else
 583           if ( arepen(1).eq.a4 ) then
 584             cofape(indpen,3) = 8
 585           else
 586             cofape(indpen,3) = 4
 587           endif
 588         endif
 589 #ifdef _DEBUG_HOMARD_
 590           if ( larete.eq.-8 ) then
 591       write (ulsort,90002)'aretes penta  7-9',(arepen(jaux),jaux=7,9)
 592             endif
 593 #endif
 594 c
 595 c 2.6.4. ==> Face 4 : par definition du pentaedre, elle s'appuie sur a2.
 596 c   Selon l'orientation, la 2eme arete du pentaedre borde le 2eme ou
 597 c   le 3eme joint.
 598 c   Par construction, l'arete dupliquee est la 1ere et la 3eme du
 599 c   quadrangle (mmag31), donc il y a 4 possibilites de positionnement :
 600 c     Si (a2,a7,a5,a8) du pentaedre = (a4,a1,a2,a3) du quad : code = 2
 601 c     Si (a2,a7,a5,a8) du pentaedre = (a2,a1,a4,a3) du quad : code = 6
 602 c     Si (a2,a7,a5,a8) du pentaedre = (a4,a3,a2,a1) du quad : code = 8
 603 c     Si (a2,a7,a5,a8) du pentaedre = (a2,a3,a4,a1) du quad : code = 4
 604 c
 605         lequad = quajoi(nujolo(2))
 606         facpen(indpen,4) = lequad
 607 c
 608         if ( arepen(7).eq.arequa(lequad,1) ) then
 609           if ( arepen(2).eq.arequa(lequad,4) ) then
 610             cofape(indpen,4) = 2
 611           else
 612             cofape(indpen,4) = 6
 613           endif
 614           arepen(8) = arequa(lequad,3)
 615         else
 616           if ( arepen(2).eq.arequa(lequad,4) ) then
 617             cofape(indpen,4) = 8
 618           else
 619             cofape(indpen,4) = 4
 620           endif
 621           arepen(8) = arequa(lequad,1)
 622         endif
 623 #ifdef _DEBUG_HOMARD_
 624           if ( larete.eq.-8 ) then
 625       write (ulsort,90002)'aretes penta  7-9',(arepen(jaux),jaux=7,9)
 626             endif
 627 #endif
 628 c
 629 c 2.6.5. ==> Face 5 : par definition du pentaedre, elle s'appuie sur a3.
 630 c   Selon l'orientation, la 3eme arete du pentaedre borde le 2eme ou
 631 c   le 3eme joint.
 632 c   Par construction, l'arete dupliquee est la 1ere et la 3eme du
 633 c   quadrangle (mmag31), donc il y a 4 possibilites de positionnement :
 634 c     Si (a3,a8,a6,a9) du pentaedre = (a4,a1,a2,a3) du quad : code = 2
 635 c     Si (a3,a8,a6,a9) du pentaedre = (a2,a1,a4,a3) du quad : code = 6
 636 c     Si (a3,a8,a6,a9) du pentaedre = (a4,a3,a2,a1) du quad : code = 8
 637 c     Si (a3,a8,a6,a9) du pentaedre = (a2,a3,a4,a1) du quad : code = 4
 638 c
 639         lequad = quajoi(nujolo(3))
 640         facpen(indpen,5) = lequad
 641 c
 642         if ( arepen(9).eq.arequa(quajoi(3),3) ) then
 643           if ( arepen(3).eq.arequa(quajoi(3),4) ) then
 644             cofape(indpen,5) = 2
 645           else
 646             cofape(indpen,5) = 6
 647           endif
 648         else
 649           if ( aredup(3).eq.arequa(quajoi(3),4) ) then
 650             cofape(indpen,5) = 8
 651           else
 652             cofape(indpen,5) = 4
 653           endif
 654         endif
 655 c
 656 c 2.6.6. ==> nujoin est le numero du joint parmi tous les joints.
 657 c            Il faut ajouter 1 pour tenir compte de la famille libre.
 658 c
 659         fampen(indpen) = nujoin + 1
 660 c
 661         hetpen(indpen)  = 0
 662         filpen(indpen)  = 0
 663         perpen(indpen)  = 0
 664 c
 665 #ifdef _DEBUG_HOMARD_
 666           if ( larete.eq.-8 ) then
 667       write (ulsort,texte(langue,16)) mess14(langue,1,7), indpen, 0
 668       do 4444 , jaux = 1, 5
 669         write (ulsort,90001) 'face/code', jaux,
 670      >                       facpen(indpen,jaux),cofape(indpen,jaux)
 671  4444 continue
 672       write (ulsort,90002)'aretes penta  1-3',(arepen(jaux),jaux=1,3)
 673       write (ulsort,90002)'aretes penta  4-6',(arepen(jaux),jaux=4,6)
 674       write (ulsort,90002)'aretes penta  7-9',(arepen(jaux),jaux=7,9)
 675       write (ulsort,90002)'sommets penta 1-3', (sompen(jaux),jaux=1,3)
 676       write (ulsort,90002)'sommets penta 4-6', (sompen(jaux),jaux=4,6)
 677         endif
 678 #endif
 679 c
 680     2 continue
 681 c
 682 c====
 683 c 5. la fin
 684 c====
 685 c
 686  5555 continue
 687 c
 688       if ( codret.ne.0 ) then
 689 c
 690 #include "envex2.h"
 691 c
 692       write (ulsort,texte(langue,1)) 'Sortie', nompro
 693       write (ulsort,texte(langue,2)) codret
 694 c
 695       endif
 696 c
 697 #ifdef _DEBUG_HOMARD_
 698       write (ulsort,texte(langue,1)) 'Sortie', nompro
 699       call dmflsh (iaux)
 700 #endif
 701 c
 702       end