src/tool/Creation_Maillage/cmrdpe.F

   1       subroutine cmrdpe ( somare, hetare, filare, merare,
   2      >                    aretri, hettri,
   3      >                    filtri, pertri, nivtri,
   4      >                    arequa, hetqua,
   5      >                    filqua, perqua, nivqua,
   6      >                    facpen, cofape, hetpen,
   7      >                    filpen, perpen,
   8      >                    famare, famtri, famqua, fampen,
   9      >                    indare, indtri, indqua, indpen,
  10      >                    ulsort, langue, codret )
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c
  31 c    Creation du Maillage - Raffinement - Decoupage des PEntaedres
  32 c    -           -          -             -             --
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . somare . es  .2*nouvar. numeros des extremites d'arete             .
  38 c . hetare . es  . nouvar . historique de l'etat des aretes            .
  39 c . filare . es  . nouvar . premiere fille des aretes                  .
  40 c . merare . es  . nouvar . mere des aretes                            .
  41 c . aretri . e   .nouvtr*3. numeros des 3 aretes des triangles         .
  42 c . hettri . e   . nouvtr . historique de l'etat des triangles         .
  43 c . filtri . e   . nouvtr . premier fils des triangles                 .
  44 c . pertri . e   . nouvtr . pere des triangles                         .
  45 c . nivtri . e   . nouvtr . niveau des triangles                       .
  46 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  47 c . hetqua . e   . nouvqu . historique de l'etat des quadrangles       .
  48 c . filqua . e   . nouvqu . premier fils des quadrangles               .
  49 c . perqua . e   . nouvqu . pere des quadrangles                       .
  50 c . nivqua . e   . nouvqu . niveau des quadrangles                     .
  51 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  52 c . cofape . e   .nouvpf*5. code des faces des pentaedres              .
  53 c . hetpen . es  . nouvpe . historique de l'etat des pentaedres        .
  54 c . filpen . es  . nouvpe . premier fils des pentaedres                .
  55 c . perpen . e   . nouvpe . pere des pentaedres                        .
  56 c . famare . es  . nouvar . famille des aretes                         .
  57 c . famtri . es  . nouvtr . famille des triangles                      .
  58 c . famqua . es  . nouvqu . famille des quadrangles                    .
  59 c . fampen . es  . nouvpe . famille des pentaedres                     .
  60 c . indare . es  . 1      . indice de la derniere arete creee          .
  61 c . indtri . es  . 1      . indice du dernier triangle cree            .
  62 c . indqua . es  . 1      . indice du dernier quadrangle cree          .
  63 c . indpen . es  . 1      . indice du dernier pentaedre cree           .
  64 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  65 c . langue . e   .    1   . langue des messages                        .
  66 c .        .     .        . 1 : francais, 2 : anglais                  .
  67 c . codret . es  .    1   . code de retour des modules                 .
  68 c .        .     .        . 0 : pas de probleme                        .
  69 c ______________________________________________________________________
  70 c
  71 c====
  72 c 0. declarations et dimensionnement
  73 c====
  74 c
  75 c 0.1. ==> generalites
  76 c
  77       implicit none
  78       save
  79 c
  80       character*6 nompro
  81       parameter ( nompro = 'CMRDPE' )
  82 c
  83 #include "nblang.h"
  84 c
  85 c 0.2. ==> communs
  86 c
  87 #include "envex1.h"
  88 #include "i1i2i3.h"
  89 #include "cofpen.h"
  90 #include "nombpe.h"
  91 #include "nouvnb.h"
  92 #include "defiqu.h"
  93 #include "impr02.h"
  94 c
  95 c 0.3. ==> arguments
  96 c
  97       integer somare(2,nouvar), hetare(nouvar), filare(nouvar)
  98       integer merare(nouvar)
  99       integer aretri(nouvtr,3), hettri(nouvtr)
 100       integer filtri(nouvtr), pertri(nouvtr), nivtri(nouvtr)
 101       integer arequa(nouvqu,4), hetqua(nouvqu)
 102       integer filqua(nouvqu), perqua(nouvqu), nivqua(nouvqu)
 103       integer facpen(nouvpf,5), cofape(nouvpf,5)
 104       integer hetpen(nouvpe), filpen(nouvpe), perpen(nouvpe)
 105       integer famare(nouvar), famtri(nouvtr), famqua(nouvqu)
 106       integer fampen(nouvpe)
 107       integer indare, indtri, indqua, indpen
 108 c
 109       integer ulsort, langue, codret
 110 c
 111 c 0.4. ==> variables locales
 112 c
 113       integer dt, etat, lepent, pere, nupent
 114       integer niveau, cf1, cf2, cf3, cf4, cf5, f1, f2, f3, f4, f5
 115       integer codefa
 116       integer a1ff1, a2ff1, a3ff1, a4ff2, a5ff2, a6ff2
 117       integer n1nf3, n9nf3, n4nf3, n7nf3
 118       integer n2nf4, n7nf4, n5nf4, n8nf4
 119       integer n3nf5, n8nf5, n6nf5, n9nf5
 120       integer ff1, ff2
 121       integer f1ff1, f2ff1, f3ff1, f4ff2, f5ff2, f6ff2
 122       integer f3s1, f3s3, f3s6, f3s4
 123       integer f4s2, f4s1, f4s4, f4s5
 124       integer f5s3, f5s2, f5s5, f5s6
 125       integer nf3, nf4, nf5
 126       integer nf3nf4, nf4nf5, nf5nf3
 127       integer pf1, pf1n7, pf1n8, pf1n9
 128       integer pf3f1, pf3f2, pf4f1, pf4f2, pf5f1, pf5f2
 129 c
 130       integer iaux, jaux
 131 c
 132       integer nbmess
 133       parameter ( nbmess = 10 )
 134       character*80 texte(nblang,nbmess)
 135 c
 136 c 0.5. ==> initialisations
 137 c ______________________________________________________________________
 138 c
 139 c====
 140 c 1. preliminaires
 141 c====
 142 c
 143 c 1.1. ==> messages
 144 c
 145 #include "impr01.h"
 146 c
 147 #ifdef _DEBUG_HOMARD_
 148       write (ulsort,texte(langue,1)) 'Entree', nompro
 149       call dmflsh (iaux)
 150 #endif
 151 c
 152       texte(1,4) = '(''Decoupage du '',a,i10)'
 153       texte(1,5) =
 154      > '(''.. Face :'',i10,'', d''''aretes'',4i10,'', code'',i2)'
 155       texte(1,6) = '(''.. Noeuds milieux des faces'',6i10)'
 156       texte(1,7) = '(''.. Noeud milieu'',i10,'', coor :'',3g15.7)'
 157       texte(1,9) = '(''.. Creation des '',a,'' internes'')'
 158       texte(1,10) = '(''.. Creation des 8 pentaedres'')'
 159 c
 160       texte(2,4) = '(''Splitting of '',a,'' #'',i10)'
 161       texte(2,5) =
 162      > '(''.. Face :'',i10,'', with edges'',4i10,'', code'',i2)'
 163       texte(2,6) = '(''.. Center nodes for faces'',6i10)'
 164       texte(2,7) = '(''.. Central node'',i10,'', coor :'',3g15.7)'
 165       texte(2,9) = '(''.. Creation of internal '',a)'
 166       texte(2,10) = '(''.. Creation of 8 pentahedrons'')'
 167 c
 168 c====
 169 c 2. decoupage en 8 des pentaedres dont les 5 faces sont coupees en 4
 170 c====
 171 c
 172       do 200 , lepent = 1 , nbpepe
 173 c
 174        if ( mod(hetpen(lepent),100) .eq. 0 ) then
 175 c
 176 c 2.1. decoupage ?
 177 c
 178         dt = 0
 179         do 211 , iaux = 1 , 2
 180           jaux = facpen(lepent,iaux)
 181           if ( mod(hettri(jaux),10).eq.4 .or.
 182      >         mod(hettri(jaux),10).eq.5 .or.
 183      >         mod(hettri(jaux),10).eq.6 .or.
 184      >         mod(hettri(jaux),10).eq.7 .or.
 185      >         mod(hettri(jaux),10).eq.9) then
 186             dt = dt + 1
 187           endif
 188   211   continue
 189         do 212 , iaux = 3 , 5
 190           jaux = facpen(lepent,iaux)
 191           if ( mod(hetqua(jaux),100).eq.4 .or.
 192      >         mod(hetqua(jaux),100).eq.99 ) then
 193             dt = dt + 1
 194           endif
 195   212   continue
 196 c
 197         if ( dt.eq.5 ) then
 198 #ifdef _DEBUG_HOMARD_
 199       write (ulsort,texte(langue,4)) mess14(langue,1,7), lepent
 200 #endif
 201 c
 202 c 2.2. ==> description des 5 faces du pentaedre
 203 c
 204 c 2.2.1. ==> description de la face 1
 205 c
 206           f1 = facpen(lepent,1)
 207           cf1 = cofape(lepent,1)
 208 c
 209 c 2.2.1.1. ==> reperage des 4 triangles fils
 210 c              fiff1 : face opposee a arete ai
 211 c              ainsi f1ff1 contient le sommet s2
 212 c
 213           ff1 = filtri(f1)
 214           f1ff1 = ff1 + i1(cf1)
 215           f2ff1 = ff1 + i2(cf1)
 216           f3ff1 = ff1 + i3(cf1)
 217 c
 218 c 2.2.1.2. ==> reperage des 3 aretes internes
 219 c              aiff1 : arete de ff1 qui est // a ai
 220 c
 221           a1ff1 = aretri(ff1,i1(cf1))
 222           a2ff1 = aretri(ff1,i2(cf1))
 223           a3ff1 = aretri(ff1,i3(cf1))
 224 c
 225 c 2.2.2. ==> description de la face 2
 226 c
 227           f2 = facpen(lepent,2)
 228           cf2 = cofape(lepent,2)
 229 c
 230 c 2.2.2.1. ==> reperage des 4 triangles fils
 231 c
 232           ff2 = filtri(f2)
 233           f4ff2 = ff2 + i1(cf2)
 234           f6ff2 = ff2 + i2(cf2)
 235           f5ff2 = ff2 + i3(cf2)
 236 c
 237 c 2.2.2.2. ==> reperage des 3 aretes internes
 238 c
 239           a4ff2 = aretri(ff2,i1(cf2))
 240           a6ff2 = aretri(ff2,i2(cf2))
 241           a5ff2 = aretri(ff2,i3(cf2))
 242 c
 243 c 2.2.3. ==> description de la face 3
 244 c
 245           f3 = facpen(lepent,3)
 246           cf3 = cofape(lepent,3)
 247 c
 248 c 2.2.3.1. ==> reperage des 4 quadrangles fils
 249 c
 250           f3s1 = filqua(f3) + defiq1(cf3)
 251           f3s3 = filqua(f3) + defiq2(cf3)
 252           f3s6 = filqua(f3) + defiq3(cf3)
 253           f3s4 = filqua(f3) + defiq4(cf3)
 254 c        write(ulsort,*) 'f3s1, f3s3, f3s6, f3s4 ',f3s1, f3s3, f3s6,f3s4
 255 c
 256 c 2.2.3.2. ==> reperage des 4 aretes internes
 257 c
 258           if ( cf3.lt.5 ) then
 259            n1nf3 = arequa(f3s1,2)
 260            n9nf3 = arequa(f3s3,2)
 261            n4nf3 = arequa(f3s6,2)
 262            n7nf3 = arequa(f3s4,2)
 263           else
 264            n1nf3 = arequa(f3s3,2)
 265            n9nf3 = arequa(f3s6,2)
 266            n4nf3 = arequa(f3s4,2)
 267            n7nf3 = arequa(f3s1,2)
 268           endif
 269 c
 270 c 2.2.4. ==> description de la face 4
 271 c
 272           f4 = facpen(lepent,4)
 273           cf4 = cofape(lepent,4)
 274 c
 275 c 2.2.4.1. ==> reperage des 4 quadrangles fils
 276 c
 277           f4s2 = filqua(f4) + defiq1(cf4)
 278           f4s1 = filqua(f4) + defiq2(cf4)
 279           f4s4 = filqua(f4) + defiq3(cf4)
 280           f4s5 = filqua(f4) + defiq4(cf4)
 281 c
 282 c 2.2.4.2. ==> reperage des 4 aretes internes
 283 c
 284           if ( cf4.lt.5 ) then
 285            n2nf4 = arequa(f4s2,2)
 286            n7nf4 = arequa(f4s1,2)
 287            n5nf4 = arequa(f4s4,2)
 288            n8nf4 = arequa(f4s5,2)
 289           else
 290            n2nf4 = arequa(f4s1,2)
 291            n7nf4 = arequa(f4s4,2)
 292            n5nf4 = arequa(f4s5,2)
 293            n8nf4 = arequa(f4s2,2)
 294           endif
 295 c
 296 c 2.2.5. ==> description de la face 5
 297 c
 298           f5 = facpen(lepent,5)
 299           cf5 = cofape(lepent,5)
 300 c
 301 c 2.2.5.1. ==> reperage des 4 quadrangles fils
 302 c
 303           f5s3 = filqua(f5) + defiq1(cf5)
 304           f5s2 = filqua(f5) + defiq2(cf5)
 305           f5s5 = filqua(f5) + defiq3(cf5)
 306           f5s6 = filqua(f5) + defiq4(cf5)
 307 c
 308 c 2.2.5.2. ==> reperage des 4 aretes internes
 309 c
 310           if ( cf5.lt.5 ) then
 311            n3nf5 = arequa(f5s3,2)
 312            n8nf5 = arequa(f5s2,2)
 313            n6nf5 = arequa(f5s5,2)
 314            n9nf5 = arequa(f5s6,2)
 315           else
 316            n3nf5 = arequa(f5s2,2)
 317            n8nf5 = arequa(f5s5,2)
 318            n6nf5 = arequa(f5s6,2)
 319            n9nf5 = arequa(f5s3,2)
 320           endif
 321 c
 322 #ifdef _DEBUG_HOMARD_
 323           write(ulsort,texte(langue,5)) f1,aretri(f1,1),aretri(f1,2)
 324      >         ,aretri(f1,3),0,cf1
 325           write(ulsort,texte(langue,5)) f2,aretri(f2,1),aretri(f2,2)
 326      >         ,aretri(f2,3),0,cf2
 327           write(ulsort,texte(langue,5)) f3,arequa(f3,1),arequa(f3,2)
 328      >         ,arequa(f3,3),arequa(f3,4),cf3
 329           write(ulsort,texte(langue,5)) f4,arequa(f4,1),arequa(f4,2)
 330      >         ,arequa(f4,3),arequa(f4,4),cf4
 331           write(ulsort,texte(langue,5)) f5,arequa(f5,1),arequa(f5,2)
 332      >         ,arequa(f5,3),arequa(f5,4),cf5
 333 #endif
 334 c
 335 c 2.3. ==> noeuds milieux des faces du pentaedre
 336 c
 337           nf3 = somare(2,n1nf3)
 338           nf4 = somare(2,n2nf4)
 339           nf5 = somare(2,n3nf5)
 340 #ifdef _DEBUG_HOMARD_
 341       write (ulsort,texte(langue,6)) nf3, nf4, nf5
 342 #endif
 343 c
 344 c 2.4. ==> creation des aretes internes au pentaedre
 345 c
 346 #ifdef _DEBUG_HOMARD_
 347       write (ulsort,texte(langue,9)) mess14(langue,3,1)
 348 #endif
 349 c
 350 c 2.4.1. ==> leurs numeros
 351 c
 352           nf3nf4 = indare + 1
 353           nf4nf5 = indare + 2
 354           nf5nf3 = indare + 3
 355           indare = nf5nf3
 356 c
 357 c 2.4.2. ==> les numeros de leurs sommets avec la convention ad'hoc
 358 c
 359           somare(1,nf3nf4) = min(nf3,nf4)
 360           somare(2,nf3nf4) = max(nf3,nf4)
 361           somare(1,nf4nf5) = min(nf4,nf5)
 362           somare(2,nf4nf5) = max(nf4,nf5)
 363           somare(1,nf5nf3) = min(nf3,nf5)
 364           somare(2,nf5nf3) = max(nf3,nf5)
 365 c
 366 c 2.4.3. ==> leur famille : libre
 367 c
 368           famare(nf3nf4) = 1
 369           famare(nf4nf5) = 1
 370           famare(nf5nf3) = 1
 371 c
 372 c 2.4.4. ==> la parente
 373 c
 374           hetare(nf3nf4) = 50
 375           hetare(nf4nf5) = 50
 376           hetare(nf5nf3) = 50
 377           merare(nf3nf4) = 0
 378           merare(nf4nf5) = 0
 379           merare(nf5nf3) = 0
 380           filare(nf3nf4) = 0
 381           filare(nf4nf5) = 0
 382           filare(nf5nf3) = 0
 383 c
 384 c 2.5. ==> creation des 4 triangles internes
 385 c 2.5.1. ==> recuperation du niveau commun a tous les triangles fils
 386 c            le code est 1 par defaut
 387 c
 388           niveau = nivtri(ff1)
 389           codefa = 1
 390 c
 391 c 2.5.2. ==> creation
 392 c
 393           pf1 = indtri + 1
 394           call cmctri ( aretri, famtri, hettri,
 395      >                  filtri, pertri, nivtri,
 396      >                  pf1, nf3nf4, nf4nf5, nf5nf3,
 397      >                  codefa, niveau )
 398 c
 399           pf1n7 = indtri + 2
 400           call cmctri ( aretri, famtri, hettri,
 401      >                  filtri, pertri, nivtri,
 402      >                  pf1n7, nf3nf4, n7nf3, n7nf4,
 403      >                  codefa, niveau )
 404 c
 405           pf1n8 = indtri + 3
 406           call cmctri ( aretri, famtri, hettri,
 407      >                  filtri, pertri, nivtri,
 408      >                  pf1n8, nf4nf5, n8nf4, n8nf5,
 409      >                  codefa, niveau )
 410 c
 411           pf1n9 = indtri + 4
 412           call cmctri ( aretri, famtri, hettri,
 413      >                  filtri, pertri, nivtri,
 414      >                  pf1n9, nf5nf3, n9nf5, n9nf3,
 415      >                  codefa, niveau )
 416 c
 417           indtri = pf1n9
 418 c
 419 c 2.6. ==> creation des 6 quadrangles internes
 420 c         tous ces quadrangles sont crees avec le code arbitraire 1
 421 c         et avec le meme niveau que les triangles
 422 c
 423           pf3f1 = indqua + 1
 424           call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua,
 425      >                  pf3f1, a1ff1, n3nf5, nf4nf5, n2nf4,
 426      >                  codefa, niveau )
 427 c
 428           pf3f2 = indqua + 2
 429           call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua,
 430      >                  pf3f2, nf4nf5, n6nf5, a4ff2, n5nf4,
 431      >                  codefa, niveau )
 432 c
 433           pf4f1 = indqua + 3
 434           call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua,
 435      >                  pf4f1, a2ff1, n1nf3, nf5nf3, n3nf5,
 436      >                  codefa, niveau )
 437 c
 438           pf4f2 = indqua + 4
 439           call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua,
 440      >                  pf4f2, nf5nf3, n4nf3, a5ff2, n6nf5,
 441      >                  codefa, niveau )
 442 c
 443           pf5f1 = indqua + 5
 444           call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua,
 445      >                  pf5f1, a3ff1, n2nf4, nf3nf4, n1nf3,
 446      >                  codefa, niveau )
 447 c
 448           pf5f2 = indqua + 6
 449           call cmcqua ( arequa, famqua, hetqua, filqua, perqua, nivqua,
 450      >                  pf5f2, nf3nf4, n5nf4, a6ff2, n4nf3,
 451      >                  codefa, niveau )
 452 c
 453           indqua = pf5f2
 454 c
 455 c 2.7. ==> creation des 8 pentaedres
 456 c
 457 #ifdef _DEBUG_HOMARD_
 458       write (ulsort,texte(langue,10))
 459 #endif
 460 c
 461           iaux = fampen(lepent)
 462 c
 463           nupent = indpen + 1
 464           call cmcpen ( facpen, cofape, fampen,
 465      >                  hetpen, filpen, perpen,
 466      >                   f3ff1,  pf1n7,   f3s1,
 467      >                    f4s1,  pf5f1,
 468      >                     cf1,      6, cofp08(cf3,defiq1(cf3)),
 469      >                  cofp08(cf4,defiq2(cf4)), 1,
 470      >                  lepent,   iaux, nupent )
 471 c
 472           nupent = indpen + 2
 473           call cmcpen ( facpen, cofape, fampen,
 474      >                  hetpen, filpen, perpen,
 475      >                   f1ff1,  pf1n8,  pf3f1,
 476      >                    f4s2,   f5s2,
 477      >                     cf1,      4,      1,
 478      >                  cofp08(cf4,defiq1(cf4)),
 479      >                  cofp08(cf5,defiq2(cf5)),
 480      >                  lepent,   iaux, nupent )
 481 c
 482           nupent = indpen + 3
 483           call cmcpen ( facpen, cofape, fampen,
 484      >                  hetpen, filpen, perpen,
 485      >                   f2ff1,  pf1n9,   f3s3,
 486      >                   pf4f1,   f5s3,
 487      >                     cf1,      5, cofp08(cf3,defiq2(cf3)),
 488      >                       1, cofp08(cf5,defiq1(cf5)),
 489      >                  lepent,   iaux, nupent )
 490 c
 491           nupent = indpen + 4
 492           call cmcpen ( facpen, cofape, fampen,
 493      >                  hetpen, filpen, perpen,
 494      >                   pf1n7,  f6ff2,   f3s4,
 495      >                    f4s4,  pf5f2,
 496      >                       3,    cf2, cofp08(cf3,defiq4(cf3)),
 497      >                  cofp08(cf4,defiq3(cf4)), 1,
 498      >                  lepent,   iaux, nupent )
 499 c
 500           nupent = indpen + 5
 501           call cmcpen ( facpen, cofape, fampen,
 502      >                  hetpen, filpen, perpen,
 503      >                   pf1n8,  f4ff2,  pf3f2,
 504      >                    f4s5,   f5s5,
 505      >                       1,    cf2,      1,
 506      >                 cofp08(cf4,defiq4(cf4)), cofp08(cf5,defiq3(cf5)),
 507      >                  lepent,   iaux, nupent )
 508 c
 509           nupent = indpen + 6
 510           call cmcpen ( facpen, cofape, fampen,
 511      >                  hetpen, filpen, perpen,
 512      >                   pf1n9,  f5ff2,   f3s6,
 513      >                   pf4f2,   f5s6,
 514      >                       2,    cf2, cofp08(cf3,defiq3(cf3)),
 515      >                       1, cofp08(cf5,defiq4(cf5)),
 516      >                  lepent,   iaux, nupent )
 517 c
 518           nupent = indpen + 7
 519           call cmcpen ( facpen, cofape, fampen,
 520      >                  hetpen, filpen, perpen,
 521      >                     ff1,    pf1,  pf3f1,
 522      >                   pf4f1,  pf5f1,
 523      >                     cf1,      6,      5,
 524      >                       5,      5,
 525      >                  lepent,   iaux, nupent )
 526 c
 527           nupent = indpen + 8
 528           call cmcpen ( facpen, cofape, fampen,
 529      >                  hetpen, filpen, perpen,
 530      >                     pf1,    ff2,  pf3f2,
 531      >                   pf4f2,  pf5f2,
 532      >                       3,    cf2,      5,
 533      >                       5,      5,
 534      >                  lepent,   iaux, nupent )
 535 c
 536           indpen = nupent
 537 c
 538 c 2.7.3. ==> mise a jour du pentaedre courant et de son pere eventuel
 539 c
 540           filpen(lepent) = indpen - 7
 541           hetpen(lepent) = hetpen(lepent) + 80
 542           pere = perpen(lepent)
 543           if ( pere .ne. 0 ) then
 544             etat = hetpen(pere)
 545             hetpen(pere) = etat - mod(etat,100) + 99
 546           endif
 547 c
 548         endif
 549 c
 550        endif
 551 c
 552   200 continue
 553 c
 554 c====
 555 c 3. la fin
 556 c====
 557 c
 558       if ( codret.ne.0 ) then
 559 c
 560 #include "envex2.h"
 561 c
 562       write (ulsort,texte(langue,1)) 'Sortie', nompro
 563       write (ulsort,texte(langue,2)) codret
 564 c
 565       endif
 566 c
 567 #ifdef _DEBUG_HOMARD_
 568       write (ulsort,texte(langue,1)) 'Sortie', nompro
 569       call dmflsh (iaux)
 570 #endif
 571 c
 572       end