src/tool/Modification/mmag13.F

   1       subroutine mmag13 ( muarmx, nbarmu, multax, multnx,
   2      >                    somare,
   3      >                    nbjois, tbaux2,
   4      >                    nbduno, nbduar, nbtrtn, nbqutn,
   5      >                    tbau30, tbau40,
   6      >                    tbau31, tbau41,
   7      >                    tbau51, tbau52, tbau53,
   8      >                    nbjoit, nbpejt, nbtrjt,
   9      >                    nbjoiq, nbhejq, nbqujq,
  10      >                    nbjp06, nbte06,
  11      >                    nbjp09, nbpe09,
  12      >                    nbjp12, nbhe12,
  13      >                    tbaux5,
  14      >                    ulsort, langue, codret )
  15 c ______________________________________________________________________
  16 c
  17 c                             H O M A R D
  18 c
  19 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  20 c
  21 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  22 c aupres des huissiers de justice Simart et Lavoir a Clamart
  23 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  24 c aupres des huissiers de justice
  25 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  26 c
  27 c    HOMARD est une marque deposee d'Electricite de France
  28 c
  29 c Copyright EDF 1996
  30 c Copyright EDF 1998
  31 c Copyright EDF 2002
  32 c Copyright EDF 2020
  33 c ______________________________________________________________________
  34 c
  35 c    Modification de Maillage - AGregat - phase 1.3
  36 c    -               -          --              - -
  37 c    . Creation des mailles a partir des aretes et noeuds multiples
  38 c ______________________________________________________________________
  39 c .        .     .        .                                            .
  40 c .  nom   . e/s . taille .           description                      .
  41 c .____________________________________________________________________.
  42 c . muarmx . e   .   1    . ordre de multiplicite des aretes maximal   .
  43 c .        .     .        . possible                                   .
  44 c . nbarmu . e   . muarmx . nombre d'aretes par ordre de multiplicite  .
  45 c . multax . e   .   1    . ordre de multiplicite des aretes maximal   .
  46 c . munrmx . e   .   1    . ordre de multiplicite des noeuds maximal   .
  47 c .        .     .        . possible                                   .
  48 c . multnx . e   .   1    . ordre de multiplicite des noeuds maximal   .
  49 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  50 c . nbjois . e   .   1    . nombre de joints simples                   .
  51 c . tbaux2 . es  .   4**  . 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 . es  .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 . es  .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 . nbduno . e   .   1    . nombre de duplication de noeuds            .
  73 c . nbduar . e   .   1    . nombre de duplications d'aretes            .
  74 c . nbtrtn . e   .   1    . nouveau nombre total de triangles          .
  75 c . nbqutn . e   .   1    . nouveau nombre total de quadrangles        .
  76 c . tbau31 .  s  .   2**  . Les triangles puis les quadrangles         .
  77 c .        .     .        . construits sur un noeud multiple :         .
  78 c .        .     .        . (1,i) : noeud multiple                     .
  79 c .        .     .        . (2,i) : numero du joint multiple cree      .
  80 c . tbau41 .  s  .   4**  . Les pentaedres de joint triple, puis les   .
  81 c .        .     .        . hexaedres de joint quadruple :             .
  82 c .        .     .        . (1,i) : arete multiple                     .
  83 c .        .     .        . (2,i) : numero du joint                    .
  84 c .        .     .        . Pour le i-eme pentaedre de joint triple :  .
  85 c .        .     .        . (3,i) : triangle cree cote 1er sommet      .
  86 c .        .     .        . (4,i) : triangle cree cote 2nd sommet      .
  87 c .        .     .        . Pour le i-eme hexaedre de joint quadruple :.
  88 c .        .     .        . (3,i) : quadrangle cree cote 1er sommet    .
  89 c .        .     .        . (4,i) : quadrangle cree cote 2nd sommet    .
  90 c . tbau51 .  s  .   9**  . Les tetraedres ponctuels entre les joints  .
  91 c .        .     .        . triples (ordre 6) :                        .
  92 c .        .     .        . (1,i) : noeud multiple                     .
  93 c .        .     .        . (2,i) : triangle cote du 1er joint triple  .
  94 c .        .     .        . (3,i) : triangle cote du 2eme joint triple .
  95 c .        .     .        . (4,i) : triangle cote du 3eme joint triple .
  96 c .        .     .        . (5,i) : triangle cote du 4eme joint triple .
  97 c .        .     .        . (1+k) : pour le k-eme triangle, 1 s'il     .
  98 c .        .     .        . entre dans le joint ponctuel, -1 sinon     .
  99 c . tbau52 .  s  .  11**  . Les pentaedres ponctuels entre les joints  .
 100 c .        .     .        . triples et quadruples (ordre 9) :          .
 101 c .        .     .        . (1,i) : noeud multiple                     .
 102 c .        .     .        . (2,i) : triangle cote du 1er joint triple  .
 103 c .        .     .        . (3,i) : triangle cote du 2eme joint triple .
 104 c .        .     .        . (4,i) : quadrangle cote du 1er joint quad. .
 105 c .        .     .        . (5,i) : quadrangle cote du 2eme joint quad..
 106 c .        .     .        . (6,i) : quadrangle cote du 3eme joint quad..
 107 c .        .     .        . (1+k) : pour la k-eme face, 1 si elle      .
 108 c .        .     .        . entre dans le joint ponctuel, -1 sinon     .
 109 c . tbau53 .  s  .  13**  . Les hexaedres ponctuels entre les joints   .
 110 c .        .     .        . quadruples (ordre 12) :                    .
 111 c .        .     .        . (1,i) : noeud multiple                     .
 112 c .        .     .        . (2,i) : quadrangle cote du 1er joint quad. .
 113 c .        .     .        . (3,i) : quadrangle cote du 2eme joint quad..
 114 c .        .     .        . (4,i) : quadrangle cote du 3eme joint quad..
 115 c .        .     .        . (5,i) : quadrangle cote du 4eme joint quad..
 116 c .        .     .        . (6,i) : quadrangle cote du 5eme joint quad..
 117 c .        .     .        . (7,i) : quadrangle cote du 6eme joint quad..
 118 c .        .     .        . (1+k) : pour le k-eme quadrangle, 1 s'il   .
 119 c .        .     .        . entre dans le joint ponctuel, -1 sinon     .
 120 c . nbjoit .  s  .   1    . nombre de joints triples                   .
 121 c . nbpejt .  s  .   1    . nombre de pentaedres de joints triples     .
 122 c . nbtrjt .  s  .   1    . nombre de triangles de joints triples      .
 123 c . nbjoiq .  s  .   1    . nombre de joints quadruples                .
 124 c . nbhejq .  s  .   1    . nombre d'hexaedres de joints quadruples    .
 125 c . nbqujq .  s  .   1    . nombre de quad. crees pour j. quadruples   .
 126 c . nbjp06 .  s  .   1    . nombre de joints ponctuels ordre 6         .
 127 c . nbte06 .  s  .   1    . nombre de tetr. des j. ponctuels d'ordre 6 .
 128 c . nbjp09 .  s  .   1    . nombre de joints ponctuels ordre 9         .
 129 c . nbpe09 .  s  .   1    . nombre de pent. des j. ponctuels d'ordre 9 .
 130 c . nbjp12 .  s  .   1    . nombre de joints ponctuels ordre 12        .
 131 c . nbhe12 .  s  .   1    . nombre de hexa. des j. ponctuels d'ordre 12.
 132 c . tbaux5 . --- .   4**  . Pour la i-eme duplication d'arete :        .
 133 c .        .     .        . (1,i), (2,i), (3,i), (4,i)                 .
 134 c .        .     .        . numeros ordonnes des joints simples crees  .
 135 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 136 c . langue . e   .    1   . langue des messages                        .
 137 c .        .     .        . 1 : francais, 2 : anglais                  .
 138 c . codret . es  .    1   . code de retour des modules                 .
 139 c .        .     .        . 0 : pas de probleme                        .
 140 c ______________________________________________________________________
 141 c
 142 c====
 143 c 0. declarations et dimensionnement
 144 c====
 145 c
 146 c 0.1. ==> generalites
 147 c
 148       implicit none
 149       save
 150 c
 151       character*6 nompro
 152       parameter ( nompro = 'MMAG13' )
 153 c
 154 #include "nblang.h"
 155 c
 156 c 0.2. ==> communs
 157 c
 158 #include "envex1.h"
 159 #include "impr02.h"
 160 c
 161 #include "nombar.h"
 162 c
 163 c 0.3. ==> arguments
 164 c
 165       integer muarmx, multax, multnx
 166       integer nbarmu(muarmx)
 167 c
 168       integer somare(2,nbarto)
 169       integer nbjois
 170       integer nbduno, nbduar, nbtrtn, nbqutn
 171       integer tbaux2(4,*)
 172       integer tbau30(8,nbduno), tbau40(6,nbduar)
 173       integer tbau31(2,*), tbau41(4,*)
 174       integer tbau51(9,*), tbau52(11,*), tbau53(13,*)
 175       integer tbaux5(4,nbduar)
 176 c
 177       integer nbtrjt, nbqujq
 178       integer nbjoit, nbpejt
 179       integer nbjoiq, nbhejq
 180       integer nbjp06, nbte06
 181       integer nbjp09, nbpe09
 182       integer nbjp12, nbhe12
 183 c
 184       integer ulsort, langue, codret
 185 c
 186 c 0.4. ==> variables locales
 187 c
 188       integer iaux, jaux, kaux, laux
 189       integer jdeb, kdeb
 190       integer lequad, letria, larete
 191       integer lenoeu
 192       integer nujoin
 193 c
 194       integer nbmess
 195       parameter ( nbmess = 40 )
 196       character*80 texte(nblang,nbmess)
 197 c
 198 c 0.5. ==> initialisations
 199 c ______________________________________________________________________
 200 c
 201 c====
 202 c 1. prealables
 203 c====
 204 c 1.1. ==> messages
 205 c
 206 #include "impr01.h"
 207 c
 208 #ifdef _DEBUG_HOMARD_
 209       write (ulsort,texte(langue,1)) 'Entree', nompro
 210       call dmflsh (iaux)
 211 #endif
 212 c
 213 #include "mmag01.h"
 214 #include "impr03.h"
 215 c
 216       texte(1,31) = '(''Ordre de multiplicite :'',i2)'
 217       texte(1,32) = '(''Nombre estime de '',a,'':'',i6)'
 218       texte(1,33) = '(''Nombre reel de '',a,''  :'',i6)'
 219       texte(1,34) = '(''Creation du joint :'',i6)'
 220 c
 221       texte(2,31) = '(''Ordre of multiplicity :'',i2)'
 222       texte(2,32) = '(''Estimate number of '',a,'':'',i6)'
 223       texte(2,33) = '(''Real number of '',a,''    :'',i6)'
 224       texte(2,34) = '(''Creation of junction #'',i6)'
 225 c
 226 c 1.2. ==> Constantes
 227 c
 228       codret = 0
 229 #ifdef _DEBUG_HOMARD_
 230       write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno
 231       write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar
 232 #endif
 233 c
 234       nbtrjt = 0
 235       nbjoit = 0
 236       nbpejt = 0
 237 c
 238       nbqujq = 0
 239       nbjoiq = 0
 240       nbhejq = 0
 241 c
 242       nbjp06 = 0
 243       nbte06 = 0
 244 c
 245       nbjp09 = 0
 246       nbpe09 = 0
 247 c
 248       nbjp12 = 0
 249       nbhe12 = 0
 250 c
 251 cgn      write(ulsort,90002) 'tbaux2',4,nbjois
 252 cgn      do 1101 , kaux = 1,nbjois
 253 cgn       write(ulsort,90010) (tbaux2(jaux,kaux),jaux=1,4)
 254 cgn 1101 continue
 255 cgn      write(ulsort,90002) 'tbau30',8,nbduno
 256 cgn      do 1102 , kaux = 1,nbduno
 257 cgn       write(ulsort,90010) (tbau30(jaux,kaux),jaux=1,8)
 258 cgn 1102 continue
 259 cgn      write(ulsort,90002) 'tbau40',5,nbduar
 260 cgn      do 1102 , kaux = 1,nbduar
 261 cgn       write(ulsort,90010) (tbau40(jaux,kaux),jaux=1,6)
 262 cgn 1102 continue
 263 cgn      write(ulsort,90002) 'tbau41',4,5
 264 cgn      do 1103 , kaux = 1,5
 265 cgn       write(ulsort,90010) (tbau41(jaux,kaux),jaux=1,4)
 266 cgn 1103 continue
 267 c
 268 c====
 269 c 2. Caracterisation des noeuds muliples
 270 c====
 271 #ifdef _DEBUG_HOMARD_
 272       write (ulsort,*) '2. Caract noeuds multiples ; codret = ', codret
 273 #endif
 274 c
 275       if ( codret.eq.0 ) then
 276 c
 277       if ( multnx.ge.6 ) then
 278 c
 279         do 21 , iaux = 1 , nbduno
 280 cgn      write (ulsort,90002) 'Ordre', tbau30(8,iaux)
 281 c
 282 c 2.1. ==> Les noeuds d'ordre 6
 283 c          Ils sont a la jonction de 4 joints triples.
 284 c          Ils formeront un joint ponctuel forme d'un tetraedre.
 285 c
 286           if ( tbau30(8,iaux).eq.6 ) then
 287 c
 288             lenoeu = tbau30(1,iaux)
 289 #ifdef _DEBUG_HOMARD_
 290       write (ulsort,texte(langue,4)) ' ', mess14(langue,1,-1), lenoeu
 291 #endif
 292 c          On recherche dans les tetraedres deja crees si on en a
 293 c          un qui est base sur le meme noeud multiple. Si oui,
 294 c          on ne recommence pas !
 295 c
 296             do 211 , jaux = 1 , nbjp06
 297 c
 298               if ( tbau51(1,jaux).eq.lenoeu ) then
 299                 goto 21
 300               endif
 301 c
 302   211       continue
 303 c
 304 c         Il faut noter un nouveau joint ponctuel
 305 c
 306             nbjp06 = nbjp06 + 1
 307             tbau51(1,nbjp06) = lenoeu
 308             tbau51(2,nbjp06) = 0
 309             tbau51(3,nbjp06) = 0
 310             tbau51(4,nbjp06) = 0
 311             tbau51(5,nbjp06) = 0
 312 c
 313 c 2.2. ==> Les noeuds d'ordre 9
 314 c          Ils sont a la jonction de 2 joints triples et de 3 joints
 315 c          quadruples.
 316 c          Ils formeront un joint ponctuel forme d'un pentaedre.
 317 c
 318           elseif ( tbau30(8,iaux).eq.9 ) then
 319 c
 320             lenoeu = tbau30(1,iaux)
 321 #ifdef _DEBUG_HOMARD_
 322       write (ulsort,texte(langue,4)) ' ', mess14(langue,1,-1), lenoeu
 323 #endif
 324 c          On recherche dans les pentaedres deja crees si on en a
 325 c          un qui est base sur le meme noeud multiple. Si oui,
 326 c          on ne recommence pas !
 327 c
 328             do 221 , jaux = 1 , nbjp09
 329 c
 330               if ( tbau52(1,jaux).eq.lenoeu ) then
 331                 goto 21
 332               endif
 333 c
 334   221       continue
 335 c
 336 c         Il faut noter un nouveau joint ponctuel
 337 c
 338             nbjp09 = nbjp09 + 1
 339             tbau52(1,nbjp09) = lenoeu
 340             tbau52(2,nbjp09) = 0
 341             tbau52(3,nbjp09) = 0
 342             tbau52(4,nbjp09) = 0
 343             tbau52(5,nbjp09) = 0
 344             tbau52(6,nbjp09) = 0
 345 cgn      write (ulsort,texte(langue,34)) nbjp09
 346 cgn      write (ulsort,texte(langue,20))(tbau52(jaux,nbjp09),jaux=1,1)
 347 c
 348 c 2.3. ==> Les noeuds d'ordre 12
 349 c          Ils sont a la jonction de 6 joints quadruples.
 350 c          Ils formeront un joint ponctuel forme d'un hexaedre.
 351 c
 352           elseif ( tbau30(8,iaux).eq.12 ) then
 353 c
 354             lenoeu = tbau30(1,iaux)
 355 #ifdef _DEBUG_HOMARD_
 356       write (ulsort,texte(langue,4)) ' ', mess14(langue,1,-1), lenoeu
 357 #endif
 358 c          On recherche dans les hexaedres deja crees si on en a
 359 c          un qui est base sur le meme noeud multiple. Si oui,
 360 c          on ne recommence pas !
 361 c
 362             do 231 , jaux = 1 , nbjp12
 363 c
 364               if ( tbau53(1,jaux).eq.lenoeu ) then
 365                 goto 21
 366               endif
 367 c
 368   231       continue
 369 c
 370 c         Il faut noter un nouveau joint ponctuel
 371 c
 372             nbjp12 = nbjp12 + 1
 373             tbau53(1,nbjp12) = lenoeu
 374             do 232 , jaux = 2 , 13
 375               tbau53(jaux,nbjp12) = 0
 376   232       continue
 377 cgn      write (ulsort,texte(langue,34)) nbjp12
 378 cgn      write (ulsort,texte(langue,20))(tbau53(jaux,nbjp12),jaux=1,1)
 379 c
 380           endif
 381 c
 382    21   continue
 383 c
 384       nbte06 = nbjp06
 385       nbpe09 = nbjp09
 386       nbhe12 = nbjp12
 387 c
 388       endif
 389 c
 390 #ifdef _DEBUG_HOMARD_
 391       write (ulsort,texte(langue,21))  6, nbjp06
 392       write (ulsort,texte(langue,21))  9, nbjp09
 393       write (ulsort,texte(langue,21)) 12, nbjp12
 394 #endif
 395 c
 396       endif
 397 c
 398 c====
 399 c 3. Caracterisation des aretes triples
 400 c====
 401 #ifdef _DEBUG_HOMARD_
 402       write (ulsort,*) '3. Caract aretes triples ; codret = ', codret
 403 #endif
 404 c
 405       if ( codret.eq.0 ) then
 406 c
 407       if ( multax.ge.3 ) then
 408 c
 409         do 3 , iaux = 1 , nbduar
 410 c
 411           larete = tbau40(1,iaux)
 412 c
 413           if ( tbau40(5,iaux).eq.3 ) then
 414 c
 415 #ifdef _DEBUG_HOMARD_
 416       write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete
 417 #endif
 418 c
 419 c 3.1. ==> On recherche dans les pentaedres deja crees si on en a
 420 c          un qui est base sur la meme arete triple. Si oui,
 421 c          on ne recommence pas !
 422 c
 423             do 31 , jaux = 1 , nbpejt
 424 c
 425               if ( tbau41(1,jaux).eq.larete ) then
 426                 goto 3
 427               endif
 428 c
 429    31       continue
 430 c
 431 c 3.2. ==> On doit donc creer un nouveau pentaedre.
 432 c          On recherche dans les joints triples deja crees si on
 433 c          en a un qui est base sur les memes joints simples. Si oui,
 434 c          on en deduit le numero de joint triple a associer.
 435 c
 436             do 32 , jaux = nbjois+1 , nbjois+nbjoit
 437 c
 438               if ( tbaux5(1,iaux).eq.tbaux2(1,jaux) .and.
 439      >             tbaux5(2,iaux).eq.tbaux2(2,jaux) .and.
 440      >             tbaux5(3,iaux).eq.tbaux2(3,jaux) ) then
 441 c
 442                 nujoin = jaux
 443                 goto 320
 444 c
 445               endif
 446 c
 447    32       continue
 448 c
 449 c         Il faut creer un nouveau joint
 450 c
 451             nbjoit = nbjoit + 1
 452             nujoin = nbjois + nbjoit
 453             tbaux2(1,nujoin) = tbaux5(1,iaux)
 454             tbaux2(2,nujoin) = tbaux5(2,iaux)
 455             tbaux2(3,nujoin) = tbaux5(3,iaux)
 456 cgn      write (ulsort,texte(langue,34)) nbjoit
 457 cgn      write (ulsort,texte(langue,20))(tbaux2(jaux,nujoin),jaux=1,3)
 458 c
 459   320       continue
 460 c
 461 c
 462 c 3.3. ==> Pour ce pentaedre :
 463 c          1 : son arete directrice est la courante
 464 c          2 : le joint associe
 465 c
 466             nbpejt = nbpejt + 1
 467 c
 468             tbau41(1,nbpejt) = larete
 469             tbau41(2,nbpejt) = nujoin
 470 c
 471 c           Creations/Recuperation des 2 triangles associes
 472 c
 473             do 33 , jaux = 1 , 2
 474 c
 475               lenoeu = somare(jaux,larete)
 476 #ifdef _DEBUG_HOMARD_
 477       write (ulsort,texte(langue,4)) '. ', mess14(langue,1,-1), lenoeu
 478 #endif
 479 c
 480               do 331 , kaux = 1 , nbtrjt
 481                 if ( tbau31(1,kaux).eq.lenoeu .and.
 482      >               tbau31(2,kaux).eq.nujoin ) then
 483                   letria = kaux
 484                   goto 332
 485                 endif
 486   331         continue
 487 c
 488               nbtrjt = nbtrjt + 1
 489               tbau31(1,nbtrjt) = lenoeu
 490               tbau31(2,nbtrjt) = nujoin
 491               letria = nbtrjt
 492 c
 493   332         continue
 494 #ifdef _DEBUG_HOMARD_
 495       write (ulsort,texte(langue,4)) '. ', mess14(langue,1,2), letria
 496 #endif
 497 c
 498               tbau41(2+jaux,nbpejt) = nbtrtn + letria
 499 c
 500 c             Reperage des eventuels joints ponctuels
 501 c
 502               do 333 , kaux = 1 , nbjp06
 503 c
 504                 if ( tbau51(1,kaux).eq.lenoeu ) then
 505                   do 3331 , laux = 2 , 5
 506                     if ( tbau51(laux,kaux).eq.nbtrtn+letria ) then
 507                       goto 33
 508                     elseif ( tbau51(laux,kaux).eq.0 ) then
 509                       tbau51(laux,kaux) = nbtrtn+letria
 510                       goto 33
 511                     endif
 512  3331             continue
 513                 endif
 514 c
 515   333         continue
 516 c
 517               do 334 , kaux = 1 , nbjp09
 518 c
 519                 if ( tbau52(1,kaux).eq.lenoeu ) then
 520                   do 3341 , laux = 2 , 3
 521                     if ( tbau52(laux,kaux).eq.nbtrtn+letria ) then
 522                       goto 33
 523                     elseif ( tbau52(laux,kaux).eq.0 ) then
 524                       tbau52(laux,kaux) = nbtrtn+letria
 525                       goto 33
 526                     endif
 527  3341             continue
 528                 endif
 529 c
 530   334         continue
 531 c
 532    33       continue
 533 c
 534           endif
 535 c
 536     3   continue
 537 c
 538       endif
 539 c
 540       endif
 541 c
 542 c====
 543 c 4. Caracterisation des aretes quadruples
 544 c====
 545 #ifdef _DEBUG_HOMARD_
 546       write (ulsort,*) '4. Caract aretes quadruples ; codret = ', codret
 547 #endif
 548 c
 549       if ( codret.eq.0 ) then
 550 c
 551       if ( multax.ge.4 ) then
 552 c
 553         jdeb = nbjois + nbjoit
 554         kdeb = nbtrjt
 555 c
 556         do 4 , iaux = 1 , nbduar
 557 c
 558           larete = tbau40(1,iaux)
 559 c
 560           if ( tbau40(5,iaux).eq.4 ) then
 561 c
 562 #ifdef _DEBUG_HOMARD_
 563       write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete
 564 #endif
 565 c
 566 c 4.1. ==> On recherche dans les hexaedres deja crees si on en a
 567 c          un qui est base sur la meme arete quadruple. Si oui,
 568 c          on ne recommence pas !
 569 c
 570             do 41 , jaux = 1 , nbhejq
 571 c
 572               if ( tbau41(1,nbpejt+jaux).eq.larete ) then
 573                 goto 4
 574               endif
 575 c
 576    41       continue
 577 c
 578 #ifdef _DEBUG_HOMARD_
 579       write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete
 580 #endif
 581 c
 582 c 4.2. ==> On doit donc creer un nouvel hexaedre.
 583 c          On recherche dans les joints quadruples deja crees si on
 584 c          en a un qui est base sur les memes joints simples. Si oui,
 585 c          on en deduit le numero de joint quadruple a associer.
 586 c
 587             do 42 , jaux = jdeb+1 , jdeb+nbjoiq
 588 c
 589               if ( tbaux5(1,iaux).eq.tbaux2(1,jaux) .and.
 590      >             tbaux5(2,iaux).eq.tbaux2(2,jaux) .and.
 591      >             tbaux5(3,iaux).eq.tbaux2(3,jaux) .and.
 592      >             tbaux5(4,iaux).eq.tbaux2(4,jaux) ) then
 593 c
 594                 nujoin = jaux
 595                 goto 420
 596 c
 597               endif
 598 c
 599    42       continue
 600 c
 601 c         Il faut creer un nouveau joint
 602 c
 603             nbjoiq = nbjoiq + 1
 604             nujoin = jdeb + nbjoiq
 605             tbaux2(1,nujoin) = tbaux5(1,iaux)
 606             tbaux2(2,nujoin) = tbaux5(2,iaux)
 607             tbaux2(3,nujoin) = tbaux5(3,iaux)
 608             tbaux2(4,nujoin) = tbaux5(4,iaux)
 609 cgn      write (ulsort,texte(langue,34)) nbjoiq
 610 cgn      write (ulsort,texte(langue,20))(tbaux2(jaux,nujoin),jaux=1,4)
 611 c
 612   420       continue
 613 c
 614 c 4.3. ==> Pour cet hexaedre :
 615 c          1 : son arete directrice est la courante
 616 c          2 : le joint associe
 617 c
 618             nbhejq = nbhejq + 1
 619 c
 620             tbau41(1,nbpejt+nbhejq) = larete
 621             tbau41(2,nbpejt+nbhejq) = nujoin
 622 c
 623 c           Creations/Recuperation des 2 quadrangles associes
 624 c
 625             do 43 , jaux = 1 , 2
 626 c
 627               lenoeu = somare(jaux,larete)
 628 c
 629               do 431 , kaux = kdeb+1 , kdeb+nbqujq
 630                 if ( tbau31(1,kaux).eq.lenoeu .and.
 631      >               tbau31(2,kaux).eq.nujoin ) then
 632                   lequad = kaux - kdeb
 633                   goto 432
 634                 endif
 635   431         continue
 636 c
 637               nbqujq = nbqujq + 1
 638               tbau31(1,kdeb+nbqujq) = lenoeu
 639               tbau31(2,kdeb+nbqujq) = nujoin
 640               lequad = nbqujq
 641 c
 642   432         continue
 643 #ifdef _DEBUG_HOMARD_
 644       write (ulsort,texte(langue,4)) '. ', mess14(langue,1,4), lequad
 645       write (ulsort,*) 'nbqujq =', nbqujq,', kaux =',kdeb+nbqujq
 646 #endif
 647 c
 648               tbau41(2+jaux,nbpejt+nbhejq) = nbqutn + lequad
 649 c
 650 c             Reperage des eventuels joints ponctuels
 651 c
 652               do 433 , kaux = 1 , nbjp09
 653 c
 654                 if ( tbau52(1,kaux).eq.lenoeu ) then
 655                   do 4331 , laux = 4 , 6
 656                     if ( tbau52(laux,kaux).eq.nbqutn+lequad ) then
 657                       goto 43
 658                     elseif ( tbau52(laux,kaux).eq.0 ) then
 659                       tbau52(laux,kaux) = nbqutn+lequad
 660                       goto 43
 661                     endif
 662  4331             continue
 663                 endif
 664 c
 665   433         continue
 666 c
 667 c             Reperage des eventuels joints ponctuels
 668 c
 669               do 434 , kaux = 1 , nbjp12
 670 c
 671                 if ( tbau53(1,kaux).eq.lenoeu ) then
 672                   do 4341 , laux = 2 , 7
 673                     if ( tbau53(laux,kaux).eq.0 ) then
 674                       tbau53(laux,kaux) = nbqutn+lequad
 675                       goto 43
 676                     endif
 677  4341             continue
 678                 endif
 679 c
 680   434         continue
 681 c
 682    43       continue
 683 c
 684           endif
 685 c
 686     4   continue
 687 c
 688       endif
 689 c
 690       endif
 691 c
 692 c====
 693 c 5. Controle
 694 c====
 695 #ifdef _DEBUG_HOMARD_
 696       write (ulsort,*) '5. Controle ; codret = ', codret
 697 #endif
 698 c
 699       if ( codret.eq.0 ) then
 700 c
 701       if ( nbpejt.ne.nbarmu(3) ) then
 702         write (ulsort,texte(langue,31)) 3
 703         write (ulsort,texte(langue,32)) mess14(langue,3,1), nbarmu(3)
 704         write (ulsort,texte(langue,33)) mess14(langue,3,1), nbpejt
 705         codret = 51
 706       endif
 707 c
 708       if ( nbhejq.ne.nbarmu(4) ) then
 709         write (ulsort,texte(langue,31)) 4
 710         write (ulsort,texte(langue,32)) mess14(langue,3,1), nbarmu(4)
 711         write (ulsort,texte(langue,33)) mess14(langue,3,1), nbhejq
 712         codret = codret*100 + 52
 713       endif
 714 c
 715       endif
 716 c
 717 cgn      write(ulsort,4001) 'tbaux2',4,nbjois+nbjoit+nbjoiq
 718 cgn      do 4101 , kaux = 1,nbjois+nbjoit+nbjoiq
 719 cgn       write(ulsort,4000) (tbaux2(jaux,kaux),jaux=1,4)
 720 cgn 4101 continue
 721 cgn      write(ulsort,4001) 'tbau41',4,nbpejt+nbhejq
 722 cgn      do 4102 , kaux = 1,nbpejt+nbhejq
 723 cgn       write(ulsort,4000) (tbau41(jaux,kaux),jaux=1,4)
 724 cgn 4102 continue
 725 c
 726 c====
 727 c 6. la fin
 728 c====
 729 c
 730       if ( codret.ne.0 ) then
 731 c
 732 #include "envex2.h"
 733 c
 734       write (ulsort,texte(langue,1)) 'Sortie', nompro
 735       write (ulsort,texte(langue,2)) codret
 736 c
 737       endif
 738 c
 739 #ifdef _DEBUG_HOMARD_
 740       write (ulsort,texte(langue,1)) 'Sortie', nompro
 741       call dmflsh (iaux)
 742 #endif
 743 c
 744       end