src/tool/Modification/mmag36.F

   1       subroutine mmag36 ( indhex, nbfhe0,
   2      >                    nbhe12,
   3      >                    tbau53,
   4      >                    arequa,
   5      >                    quahex, coquhe,
   6      >                    hethex, filhex, perhex,
   7      >                    famhex,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    Modification de Maillage - AGRegat - phase 3.6
  30 c    -               -          --              - -
  31 c    Creation des mailles pour les joints ponctuels :
  32 c    . hexaedres
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . indhex . es  .   1    . indice du dernier hexaedre cree            .
  38 c . nbfhe0 . e   .   1    . nombre de familles de hexaedres creees     .
  39 c . nbhe12 . e   .   1    . nombre de hexa. des j. ponctuels d'ordre 12.
  40 c . tbau53 . e   .  13*   . Les hexaedres ponctuels entre les joints   .
  41 c .        .     . nbhe12 . quadruples (ordre 12) :                    .
  42 c .        .     .        . (1,i) : noeud multiple                     .
  43 c .        .     .        . (2,i) : quadrangle cote du 1er joint quad. .
  44 c .        .     .        . (3,i) : quadrangle cote du 2eme joint quad..
  45 c .        .     .        . (4,i) : quadrangle cote du 3eme joint quad..
  46 c .        .     .        . (5,i) : quadrangle cote du 4eme joint quad..
  47 c .        .     .        . (6,i) : quadrangle cote du 5eme joint quad..
  48 c .        .     .        . (7,i) : quadrangle cote du 6eme joint quad..
  49 c .        .     .        . (1+k) : pour le k-eme quadrangle, 1 s'il   .
  50 c .        .     .        . entre dans le joint ponctuel, -1 sinon     .
  51 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  52 c . quahex . es  .nbhecf*6. numeros des faces des hexaedres            .
  53 c . coquhe . es  .nbhecf*6. codes des faces des hexaedres              .
  54 c . hethex . es  . nbheto . historique de l'etat des hexaedres         .
  55 c . filhex . es  . nbheto . premier fils des hexaedres                 .
  56 c . perhex . es  . nbheto . pere des hexaedres                         .
  57 c . famhex . es  . nbheto . famille des hexaedres                      .
  58 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  59 c . langue . e   .    1   . langue des messages                        .
  60 c .        .     .        . 1 : francais, 2 : anglais                  .
  61 c . codret . es  .    1   . code de retour des modules                 .
  62 c .        .     .        . 0 : pas de probleme                        .
  63 c ______________________________________________________________________
  64 c
  65 c====
  66 c 0. declarations et dimensionnement
  67 c====
  68 c
  69 c 0.1. ==> generalites
  70 c
  71       implicit none
  72       save
  73 c
  74       character*6 nompro
  75       parameter ( nompro = 'MMAG36' )
  76 c
  77 #include "nblang.h"
  78 c
  79 c 0.2. ==> communs
  80 c
  81 #include "envex1.h"
  82 c
  83 #include "nombqu.h"
  84 #include "nombhe.h"
  85 #include "impr02.h"
  86 #include "j1234j.h"
  87 #include "op1234.h"
  88 #include "op1aa6.h"
  89 c
  90 c 0.3. ==> arguments
  91 c
  92       integer indhex, nbfhe0
  93       integer nbhe12
  94       integer tbau53(13,nbhe12)
  95       integer arequa(nbquto,4)
  96       integer quahex(nbhecf,6), coquhe(nbhecf,6)
  97       integer hethex(nbheto), filhex(nbheto), perhex(nbheto)
  98       integer famhex(nbheto)
  99 c
 100       integer ulsort, langue, codret
 101 c
 102 c 0.4. ==> variables locales
 103 c
 104       integer iaux, jaux, kaux, laux
 105 c
 106       integer nulofa(6), nuloar(6,4), orient(6)
 107       integer arehex(12), lequad(6)
 108 c
 109       integer nbmess
 110       parameter ( nbmess = 40 )
 111       character*80 texte(nblang,nbmess)
 112 c
 113 c 0.5. ==> initialisations
 114 c ______________________________________________________________________
 115 c
 116 c====
 117 c 1. initialisations
 118 c====
 119 c 1.1. ==> messages
 120 c
 121 #include "impr01.h"
 122 c
 123 #ifdef _DEBUG_HOMARD_
 124       write (ulsort,texte(langue,1)) 'Entree', nompro
 125       call dmflsh (iaux)
 126 #endif
 127 c
 128 #include "mmag01.h"
 129 #include "mmag02.h"
 130 #include "impr03.h"
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133       write (ulsort,texte(langue,7))
 134      >       mess14(langue,3,6)//'d''ordre 12', nbhe12
 135 #endif
 136 c
 137       codret = 0
 138 c
 139 cgn      write(ulsort,90002) 'nbnoto, nbarto, nbtrto',nbnoto, nbarto,nbtrto
 140 cgn      write(ulsort,90002) 'nbhe12',nbhe12
 141 cgn      write(ulsort,90015) (iaux,iaux=1,20)
 142 cgn      write(ulsort,90002) 'tbaux2',4,nbjoto
 143 cgn      do 1101 , kaux = 1,nbjoto
 144 cgn       write(ulsort,90015) (tbaux2(jaux,kaux),jaux=1,4)
 145 cgn 1101 continue
 146 cgn      write(ulsort,90002) 'tbau53',7,nbhe12
 147 cgn      do 1102 , kaux = 1,nbhe12
 148 cgn       write(ulsort,90015) (tbau53(jaux,kaux),jaux=1,7)
 149 cgn 1102  continue
 150 c
 151 c====
 152 c 2. Parcours des hexaedres de joint ponctuel d'ordre 12
 153 c====
 154 #ifdef _DEBUG_HOMARD_
 155       write (ulsort,texte(langue,5)) mess14(langue,3,6)
 156 #endif
 157 c
 158 c                 S5            a9             S6
 159 c                  ----------------------------
 160 c                 /.                          /.
 161 c                / .                         / .
 162 c               /  .                        /  .
 163 c              /   .                       /   .
 164 c           a6/    .                      /a5  .
 165 c            /     .                     /     .
 166 c           /   a11.                    /      .a10
 167 c          /       .    a1             /       .
 168 c       S2----------------------------- S1     .
 169 c         .        .                  .        .
 170 c         .        .           a12    .        .
 171 c         .     S8 -------------------.--------.S7
 172 c         .       /                   .       /
 173 c       a3.      /                    .a2    /
 174 c         .     /                     .     /
 175 c         .    /                      .    /
 176 c         . a8/                       .   /a7
 177 c         .  /                        .  /
 178 c         . /                         . /
 179 c         ./                          ./
 180 c         -----------------------------
 181 c        S3            a4             S4
 182 c
 183 c    . Les noeuds (1,2,3,4) definissent un quadrangle a orientation
 184 c      vers l'exterieur
 185 c     Avec le code 1, les faces sont :
 186 c     Face 1 : aretes 1, 2, 4, 3
 187 c     Face 2 : aretes 1, 6, 9, 5
 188 c     Face 3 : aretes 2, 5, 10, 7
 189 c     Face 4 : aretes 3, 8, 11, 6
 190 c     Face 5 : aretes 4, 7, 12, 8
 191 c     Face 6 : aretes 9, 11, 12, 10
 192 c
 193 c voir utarhe pour le croquis ci-dessus
 194 c
 195       do 2 , iaux = 1 , nbhe12
 196 c
 197         indhex = indhex + 1
 198 c
 199 c 2.1 ==> Recuperation des quadrangles et de leur orientation
 200 c
 201         do 21 , jaux = 1 , 6
 202           lequad(jaux) = tbau53(jaux+1,iaux)
 203           orient(jaux) = tbau53(jaux+7,iaux)
 204 cgn      write (ulsort,90015) 'quadrangle', lequad(jaux),
 205 cgn     >                     ', d''orientation', orient(jaux)
 206 cgn      write (ulsort,90002) 'aretes ',
 207 cgn     > (arequa(lequad(jaux),kaux),kaux=1,4)
 208    21   continue
 209 c
 210 #ifdef _DEBUG_HOMARD_
 211       write (ulsort,*) ' '
 212       write (ulsort,texte(langue,4)) ' ',
 213      >                     mess14(langue,1,1), tbau53(1,iaux)
 214 #endif
 215 c
 216 #ifdef _DEBUG_HOMARD_
 217       write (ulsort,texte(langue,16)) mess14(langue,1,6), indhex, 0
 218 #endif
 219 c
 220 c 2.2 ==> Positionnement des quadrangles en tant que face
 221 c         nulofa(i) = numero local dans lequad du quadrangle
 222 c                     qui correspond a la face Fi
 223 c         nuloar(i,j) = pour la face Fi, numero local de sa i-eme arete
 224 c                       dans la description de la face
 225 c 2.2.1. ==>  La face F1 est le 1er quadrangle enregistre.
 226 c   On impose :
 227 c     la 1ere arete de l'hexaedre est la 1ere arete du quadrangle ;
 228 c   --> le code sera donc 1 ou 5.
 229 c   Si l'orientation est positive, le quadrangle entre dans l'hexaedre.
 230 c   On lui donnera donc le code 1.
 231 C   Inversement, si l'orientation est negative, il va sortir
 232 c   de l'hexaedre. On lui donnera alors le code 5.
 233 c
 234         quahex(indhex,1) = lequad(1)
 235         if ( orient(1).gt.0 ) then
 236           coquhe(indhex,1) = 1
 237         else
 238           coquhe(indhex,1) = 5
 239         endif
 240 c
 241 c     Reperage des aretes de cette face
 242 c
 243         arehex(1) = arequa(lequad(1),1)
 244         if ( orient(1).gt.0 ) then
 245           arehex(2) = arequa(lequad(1),2)
 246           arehex(3) = arequa(lequad(1),4)
 247         else
 248           arehex(2) = arequa(lequad(1),4)
 249           arehex(3) = arequa(lequad(1),2)
 250         endif
 251         arehex(4) = arequa(lequad(1),3)
 252 #ifdef _DEBUG_HOMARD_
 253           if ( indhex.lt.0 ) then
 254       write (ulsort,90015) 'quadrangle pour F1', lequad(1),
 255      >                     ', d''orientation', orient(1)
 256       write (ulsort,90002) 'aretes de hex 1-4',(arehex(jaux),jaux=1,4)
 257             endif
 258 #endif
 259 c
 260 c 2.2.2. ==> La face F2 est le quadrangle qui contient l'arete 1
 261 c            C'est son arete numero 1
 262 #ifdef _DEBUG_HOMARD_
 263           if ( indhex.lt.0 ) then
 264       write (ulsort,90002) 'F2 bati sur arete 1',arehex(1)
 265         endif
 266 #endif
 267 c
 268         do 222 , jaux = 2 , 6
 269           if ( arehex(1).eq.arequa(lequad(jaux),1) ) then
 270             nulofa(2) = jaux
 271             nuloar(2,1) = 1
 272             goto 2221
 273           elseif ( arehex(1).eq.arequa(lequad(jaux),2) ) then
 274             nulofa(2) = jaux
 275             nuloar(2,1) = 2
 276             goto 2221
 277           elseif ( arehex(1).eq.arequa(lequad(jaux),3) ) then
 278             nulofa(2) = jaux
 279             nuloar(2,1) = 3
 280             goto 2221
 281           elseif ( arehex(1).eq.arequa(lequad(jaux),4) ) then
 282             nulofa(2) = jaux
 283             nuloar(2,1) = 4
 284             goto 2221
 285           endif
 286   222   continue
 287         codret = 222
 288         goto 5555
 289 c
 290  2221   continue
 291 #ifdef _DEBUG_HOMARD_
 292           if ( indhex.lt.0 ) then
 293       write (ulsort,90002) 'quadrangle pour F2', lequad(nulofa(2))
 294       write (ulsort,90002) 'aretes',
 295      >                     (arequa(lequad(nulofa(2)),jaux),jaux=1,4)
 296             endif
 297 #endif
 298 c
 299 c 2.2.3. ==> La face F3 est le quadrangle qui contient l'arete 2
 300 c            C'est son arete numero 1
 301 #ifdef _DEBUG_HOMARD_
 302           if ( indhex.lt.0 ) then
 303       write (ulsort,90002) 'F3 bati sur arete 2',arehex(2)
 304         endif
 305 #endif
 306 c
 307         do 223 , jaux = 2 , 6
 308           if ( arehex(2).eq.arequa(lequad(jaux),1) ) then
 309             nulofa(3) = jaux
 310             nuloar(3,1) = 1
 311             goto 2231
 312           elseif ( arehex(2).eq.arequa(lequad(jaux),2) ) then
 313             nulofa(3) = jaux
 314             nuloar(3,1) = 2
 315             goto 2231
 316           elseif ( arehex(2).eq.arequa(lequad(jaux),3) ) then
 317             nulofa(3) = jaux
 318             nuloar(3,1) = 3
 319             goto 2231
 320           elseif ( arehex(2).eq.arequa(lequad(jaux),4) ) then
 321             nulofa(3) = jaux
 322             nuloar(3,1) = 4
 323             goto 2231
 324           endif
 325   223   continue
 326         codret = 223
 327         goto 5555
 328 c
 329  2231   continue
 330 #ifdef _DEBUG_HOMARD_
 331           if ( indhex.lt.0 ) then
 332       write (ulsort,90002) 'quadrangle pour F3', lequad(nulofa(3))
 333       write (ulsort,90002) 'aretes',
 334      >                     (arequa(lequad(nulofa(3)),jaux),jaux=1,4)
 335             endif
 336 #endif
 337 c
 338 c 2.2.4. ==> La face F4 est le quadrangle qui contient l'arete 3
 339 c            C'est son arete numero 1
 340 #ifdef _DEBUG_HOMARD_
 341           if ( indhex.lt.0 ) then
 342       write (ulsort,90002) 'F4 bati sur arete 3',arehex(3)
 343         endif
 344 #endif
 345 c
 346         do 224 , jaux = 2 , 6
 347           if ( arehex(3).eq.arequa(lequad(jaux),1) ) then
 348             nulofa(4) = jaux
 349             nuloar(4,1) = 1
 350             goto 2241
 351           elseif ( arehex(3).eq.arequa(lequad(jaux),2) ) then
 352             nulofa(4) = jaux
 353             nuloar(4,1) = 2
 354             goto 2241
 355           elseif ( arehex(3).eq.arequa(lequad(jaux),3) ) then
 356             nulofa(4) = jaux
 357             nuloar(4,1) = 3
 358             goto 2241
 359           elseif ( arehex(3).eq.arequa(lequad(jaux),4) ) then
 360             nulofa(4) = jaux
 361             nuloar(4,1) = 4
 362             goto 2241
 363           endif
 364   224   continue
 365         codret = 224
 366         goto 5555
 367 c
 368  2241   continue
 369 #ifdef _DEBUG_HOMARD_
 370           if ( indhex.lt.0 ) then
 371       write (ulsort,90002) 'quadrangle pour F4', lequad(nulofa(4))
 372       write (ulsort,90002) 'aretes',
 373      >                     (arequa(lequad(nulofa(4)),jaux),jaux=1,4)
 374             endif
 375 #endif
 376 c
 377 c 2.2.5. ==> La face F5 est le quadrangle qui contient l'arete 4
 378 c            C'est son arete numero 1
 379 #ifdef _DEBUG_HOMARD_
 380           if ( indhex.lt.0 ) then
 381       write (ulsort,90002) 'F5 bati sur arete 4',arehex(4)
 382         endif
 383 #endif
 384 c
 385         do 225 , jaux = 2 , 6
 386           if ( arehex(4).eq.arequa(lequad(jaux),1) ) then
 387             nulofa(5) = jaux
 388             nuloar(5,1) = 1
 389             goto 2251
 390           elseif ( arehex(4).eq.arequa(lequad(jaux),2) ) then
 391             nulofa(5) = jaux
 392             nuloar(5,1) = 2
 393             goto 2251
 394           elseif ( arehex(4).eq.arequa(lequad(jaux),3) ) then
 395             nulofa(5) = jaux
 396             nuloar(5,1) = 3
 397             goto 2251
 398           elseif ( arehex(4).eq.arequa(lequad(jaux),4) ) then
 399             nulofa(5) = jaux
 400             nuloar(5,1) = 4
 401             goto 2251
 402           endif
 403   225   continue
 404         codret = 225
 405         goto 5555
 406 c
 407  2251   continue
 408 #ifdef _DEBUG_HOMARD_
 409           if ( indhex.lt.0 ) then
 410       write (ulsort,90002) 'quadrangle pour F5', lequad(nulofa(5))
 411       write (ulsort,90002) 'aretes',
 412      >                     (arequa(lequad(nulofa(5)),jaux),jaux=1,4)
 413             endif
 414 #endif
 415 c
 416 c 2.3. ==> Recherche des aretes 5, 6, 7, 8, 9, 10, 11 et 12
 417 c 2.3.1. ==> Recherche de l'arete 5, commune aux faces F2 et F3
 418 c
 419         do 231 , jaux = 1 , 4
 420           laux = arequa(lequad(nulofa(2)),jaux)
 421           do 2311 , kaux = 1, 4
 422             if ( laux.eq.arequa(lequad(nulofa(3)),kaux) ) then
 423               nuloar(2,4) = jaux
 424               nuloar(3,2) = kaux
 425               arehex(5) = laux
 426               goto 2312
 427             endif
 428  2311     continue
 429   231   continue
 430         codret = 231
 431         goto 5555
 432 c
 433  2312   continue
 434 c
 435 c 2.3.2. ==> Recherche de l'arete 6, commune aux faces F4 et F2
 436 c
 437         do 232 , jaux = 1 , 4
 438           laux = arequa(lequad(nulofa(4)),jaux)
 439           do 2321 , kaux = 1, 4
 440             if ( laux.eq.arequa(lequad(nulofa(2)),kaux) ) then
 441               nuloar(4,4) = jaux
 442               nuloar(2,2) = kaux
 443               arehex(6) = laux
 444               goto 2322
 445             endif
 446  2321     continue
 447   232   continue
 448         codret = 232
 449         goto 5555
 450 c
 451  2322   continue
 452 c
 453 c 2.3.3. ==> Recherche de l'arete 7, commune aux faces F3 et F5
 454 c
 455         do 233 , jaux = 1 , 4
 456           laux = arequa(lequad(nulofa(3)),jaux)
 457           do 2331 , kaux = 1, 4
 458             if ( laux.eq.arequa(lequad(nulofa(5)),kaux) ) then
 459               nuloar(3,4) = jaux
 460               nuloar(5,2) = kaux
 461               arehex(7) = laux
 462               goto 2332
 463             endif
 464  2331     continue
 465   233   continue
 466         codret = 233
 467         goto 5555
 468 c
 469  2332   continue
 470 c
 471 c 2.3.4. ==> Recherche de l'arete 8, commune aux faces F5 et F4
 472 c
 473         do 234 , jaux = 1 , 4
 474           laux = arequa(lequad(nulofa(5)),jaux)
 475           do 2341 , kaux = 1, 4
 476             if ( laux.eq.arequa(lequad(nulofa(4)),kaux) ) then
 477               nuloar(5,4) = jaux
 478               nuloar(4,2) = kaux
 479               arehex(8) = laux
 480               goto 2342
 481             endif
 482  2341     continue
 483   234   continue
 484         codret = 234
 485         goto 5555
 486 c
 487  2342   continue
 488 #ifdef _DEBUG_HOMARD_
 489           if ( indhex.lt.0 ) then
 490       write (ulsort,90002) 'aretes de hex 5-8',(arehex(jaux),jaux=5,8)
 491             endif
 492 #endif
 493 c
 494 c 2.4. ==> Recherche des aretes 9, 10, 11, 12
 495 c
 496         nuloar(2,3) = fp1234(nuloar(2,1),nuloar(2,2),nuloar(2,4))
 497         arehex(9) = arequa(lequad(nulofa(2)),nuloar(2,3))
 498 c
 499         nuloar(3,3) = fp1234(nuloar(3,1),nuloar(3,2),nuloar(3,4))
 500         arehex(10) = arequa(lequad(nulofa(3)),nuloar(3,3))
 501 c
 502         nuloar(4,3) = fp1234(nuloar(4,1),nuloar(4,2),nuloar(4,4))
 503         arehex(11) = arequa(lequad(nulofa(4)),nuloar(4,3))
 504 c
 505         nuloar(5,3) = fp1234(nuloar(5,1),nuloar(5,2),nuloar(5,4))
 506         arehex(12) = arequa(lequad(nulofa(5)),nuloar(5,3))
 507 #ifdef _DEBUG_HOMARD_
 508           if ( indhex.lt.0 ) then
 509       write (ulsort,90002) 'aretes de hex 9-12',(arehex(jaux),jaux=9,12)
 510             endif
 511 #endif
 512 c
 513 c 2.5.==> Mise en place de la face 2
 514 c
 515         quahex(indhex,2) = lequad(nulofa(2))
 516 c
 517         do 25 , jaux = 1 , 8
 518           if ( j1(jaux).eq.nuloar(2,1) .and.
 519      >         j2(jaux).eq.nuloar(2,2) .and.
 520      >         j3(jaux).eq.nuloar(2,3) .and.
 521      >         j4(jaux).eq.nuloar(2,4) ) then
 522             coquhe(indhex,2) = jaux
 523             goto 2511
 524           endif
 525    25   continue
 526         codret = 25
 527         goto 5555
 528  2511   continue
 529 c
 530 c 2.6.==> Mise en place de la face 3
 531 c
 532         quahex(indhex,3) = lequad(nulofa(3))
 533 c
 534         do 26 , jaux = 1 , 8
 535           if ( j1(jaux).eq.nuloar(3,1) .and.
 536      >         j2(jaux).eq.nuloar(3,2) .and.
 537      >         j3(jaux).eq.nuloar(3,3) .and.
 538      >         j4(jaux).eq.nuloar(3,4) ) then
 539             coquhe(indhex,3) = jaux
 540             goto 2611
 541           endif
 542    26   continue
 543         codret = 26
 544         goto 5555
 545  2611   continue
 546 c
 547 c 2.7.==> Mise en place de la face 4
 548 c
 549         quahex(indhex,4) = lequad(nulofa(4))
 550 c
 551         do 27 , jaux = 1 , 8
 552           if ( j1(jaux).eq.nuloar(4,1) .and.
 553      >         j2(jaux).eq.nuloar(4,2) .and.
 554      >         j3(jaux).eq.nuloar(4,3) .and.
 555      >         j4(jaux).eq.nuloar(4,4) ) then
 556             coquhe(indhex,4) = jaux
 557             goto 2711
 558           endif
 559    27   continue
 560         codret = 27
 561         goto 5555
 562  2711   continue
 563 c
 564 c 2.8.==> Mise en place de la face 5
 565 c
 566         quahex(indhex,5) = lequad(nulofa(5))
 567 c
 568         do 28 , jaux = 1 , 8
 569           if ( j1(jaux).eq.nuloar(5,1) .and.
 570      >         j2(jaux).eq.nuloar(5,2) .and.
 571      >         j3(jaux).eq.nuloar(5,3) .and.
 572      >         j4(jaux).eq.nuloar(5,4) ) then
 573             coquhe(indhex,5) = jaux
 574             goto 2811
 575           endif
 576    28   continue
 577         codret = 28
 578         goto 5555
 579  2811   continue
 580 c
 581 c 2.9.==> Mise en place de la face 6 : le dernier des quadrangles
 582 c
 583         nulofa(6) = fp1aa6(        1, nulofa(2), nulofa(3),
 584      >                     nulofa(4), nulofa(5))
 585 c
 586         do 291 , jaux = 1 , 4
 587           if ( arequa(lequad(nulofa(6)),jaux).eq.arehex(9) ) then
 588             nuloar(6,1) = jaux
 589           elseif ( arequa(lequad(nulofa(6)),jaux).eq.arehex(11) ) then
 590             nuloar(6,2) = jaux
 591           elseif ( arequa(lequad(nulofa(6)),jaux).eq.arehex(12) ) then
 592             nuloar(6,3) = jaux
 593           elseif ( arequa(lequad(nulofa(6)),jaux).eq.arehex(10) ) then
 594             nuloar(6,4) = jaux
 595           else
 596             codret = 291
 597             goto 5555
 598           endif
 599   291   continue
 600 c
 601         quahex(indhex,6) = lequad(nulofa(6))
 602 c
 603         do 292 , jaux = 1 , 8
 604           if ( j1(jaux).eq.nuloar(6,1) .and.
 605      >         j2(jaux).eq.nuloar(6,2) .and.
 606      >         j3(jaux).eq.nuloar(6,3) .and.
 607      >         j4(jaux).eq.nuloar(6,4) ) then
 608             coquhe(indhex,6) = jaux
 609             goto 2921
 610           endif
 611   292   continue
 612         codret = 292
 613         goto 5555
 614  2921   continue
 615 c
 616 c 2.10.==> Caracteristiques
 617 c          iaux est le numero du joint ponctuel.
 618 c          On decale pour tenir compte des familles HOMARD precedentes
 619 c
 620         famhex(indhex) = nbfhe0 + iaux
 621 c
 622         hethex(indhex)  = 0
 623         filhex(indhex)  = 0
 624         perhex(indhex)  = 0
 625 c
 626 #ifdef _DEBUG_HOMARD_
 627         if ( indhex.eq.-1 ) then
 628       write (ulsort,texte(langue,16)) mess14(langue,1,7), indhex, 0
 629       write (ulsort,90002)'faces ',(quahex(indhex,jaux),jaux=1,6)
 630       write (ulsort,90002)'coquhe',(coquhe(indhex,jaux),jaux=1,6)
 631       write (ulsort,90002)'aretes 1-4 ',(arehex(jaux),jaux=1,4)
 632       write (ulsort,90002)'aretes 5-8 ',(arehex(jaux),jaux=5,8)
 633       write (ulsort,90002)'aretes 9-12',(arehex(jaux),jaux=9,12)
 634         endif
 635 #endif
 636 c
 637     2 continue
 638 c
 639 c====
 640 c 5. la fin
 641 c====
 642 c
 643  5555 continue
 644 c
 645       if ( codret.ne.0 ) then
 646 c
 647 #include "envex2.h"
 648 c
 649       write (ulsort,texte(langue,1)) 'Sortie', nompro
 650       write (ulsort,texte(langue,2)) codret
 651 c
 652       endif
 653 c
 654 #ifdef _DEBUG_HOMARD_
 655       write (ulsort,texte(langue,1)) 'Sortie', nompro
 656       call dmflsh (iaux)
 657 #endif
 658 c
 659       end