src/tool/Information/infope.F

   1       subroutine infope ( choix,  lepent,
   2      >                    facpen, cofape, arepen,
   3      >                    hetpen, filpen, perpen, fppyte,
   4      >                    fampen,
   5      >                    npenho, npenca, npencs,
   6      >                    hetare, somare, np2are, coonoe,
   7      >                    hettri, nivtri,
   8      >                    hetqua, arequa, nivqua,
   9      >                    hettet, ntetca,
  10      >                    hethex,
  11      >                    hetpyr, npyrca,
  12      >                    voltri, pypetr,
  13      >                    volqua, pypequ,
  14      >                    nbpafo, nopafo,
  15      >                    ulsost,
  16      >                    ulsort, langue, codret )
  17 c ______________________________________________________________________
  18 c
  19 c                             H O M A R D
  20 c
  21 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  22 c
  23 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  24 c aupres des huissiers de justice Simart et Lavoir a Clamart
  25 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  26 c aupres des huissiers de justice
  27 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  28 c
  29 c    HOMARD est une marque deposee d'Electricite de France
  30 c
  31 c Copyright EDF 1996
  32 c Copyright EDF 1998
  33 c Copyright EDF 2002
  34 c Copyright EDF 2020
  35 c ______________________________________________________________________
  36 c
  37 c   INFOrmation : PEntaedre
  38 c   ----          --
  39 c ______________________________________________________________________
  40 c .        .     .        .                                            .
  41 c .  nom   . e/s . taille .           description                      .
  42 c .____________________________________________________________________.
  43 c . choix  . e   .  ch2   . choix                                      .
  44 c . lepent . e   .   1    . numero du pentaedre a analyser             .
  45 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  46 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  47 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  48 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  49 c . filpen . e   . nbpeto . premier fils des pentaedres                .
  50 c . perpen . e   . nbpeto . pere des pentaedres                        .
  51 c . fppyte . e   .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide   .
  52 c .        .     .        . fille du pentaedre k tel que filpen(k) = -j.
  53 c .        .     .        . fppyte(2,j) = numero du 1er tetraedre      .
  54 c .        .     .        . fils du pentaedre k tel que filpen(k) = -j .
  55 c . fampen . e   . nbpeto . famille des pentaedres                     .
  56 c . npenho . e   . repeac . numero des pentaedres dans HOMARD          .
  57 c . npenca . e   .   *    . numero des pentaedres dans le calcul       .
  58 c . npencs . e   .   *    . nro des pent. du calcul pour la solution   .
  59 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  60 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  61 c . np2are . e   . nbarto . numero du noeud p2 milieu de l'arete       .
  62 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  63 c .        .     . * sdim .                                            .
  64 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  65 c . nivtri . e   . nbtrto . niveau dans le raffinement/deraffinement   .
  66 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  67 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  68 c . nivqua . e   . nbquto . niveau dans le raffinement/deraffinement   .
  69 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  70 c . ntetca . e   .   *    . numero des tetraedres dans le calcul       .
  71 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  72 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  73 c . npyrca . e   .   *    . numero des pyramides dans le calcul        .
  74 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  75 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  76 c .        .     .        .   0 : pas de voisin                        .
  77 c .        .     .        . j>0 : tetraedre j                          .
  78 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  79 c . pypetr . a   .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
  80 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  81 c .        .     .        . pypetr(2,j) = numero du pentaedre voisin   .
  82 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  83 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  84 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  85 c .        .     .        .   0 : pas de voisin                        .
  86 c .        .     .        . j>0 : hexaedre j                           .
  87 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  88 c . pypequ . 2   .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
  89 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  90 c .        .     .        . pypequ(2,j) = numero du pentaedre voisin   .
  91 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  92 c . nbpafo . e   .   1    . nombre de paquets de fonctions             .
  93 c . nopafo . e   . nbpafo . nom des objets qui contiennent la          .
  94 c .        .     .        . description de chaque paquet de fonctions  .
  95 c . ulsost . e   .   1    . unite logique de la sortie standard        .
  96 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  97 c . langue . e   .    1   . langue des messages                        .
  98 c .        .     .        . 1 : francais, 2 : anglais                  .
  99 c . codret . es  .    1   . code de retour des modules                 .
 100 c .        .     .        . 0 : pas de probleme                        .
 101 c .        .     .        . non nul : probleme                         .
 102 c ______________________________________________________________________
 103 c
 104 c====
 105 c 0. declarations et dimensionnement
 106 c====
 107 c
 108 c 0.1. ==> generalites
 109 c
 110       implicit none
 111       save
 112 c
 113       character*6 nompro
 114       parameter ( nompro = 'INFOPE' )
 115 c
 116       integer langst
 117       parameter ( langst = 1 )
 118 c
 119 #include "nblang.h"
 120 #include "consts.h"
 121 #include "tbdim0.h"
 122 #include "meddc0.h"
 123 c
 124 c 0.2. ==> communs
 125 c
 126 #include "envex1.h"
 127 #include "inmess.h"
 128 #include "impr02.h"
 129 c
 130 #include "nomber.h"
 131 #include "nombno.h"
 132 #include "nombar.h"
 133 #include "nombtr.h"
 134 #include "nombqu.h"
 135 #include "nombte.h"
 136 #include "nombpy.h"
 137 #include "nombhe.h"
 138 #include "nombpe.h"
 139 #include "envada.h"
 140 #include "envca1.h"
 141 c
 142 c 0.3. ==> arguments
 143 c
 144       character*2 choix
 145 c
 146       integer lepent
 147 c
 148       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 149       integer hetpen(nbpeto)
 150       integer filpen(nbpeto), perpen(nbpeto), fppyte(2,nbpeco)
 151       integer fampen(nbpeto)
 152       integer npenho(repeac), npenca(*), npencs(*)
 153       integer hetare(nbarto), somare(2,nbarto), np2are(nbarto)
 154       integer hettri(nbtrto), nivtri(nbtrto)
 155       integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto)
 156       integer hettet(nbteto), ntetca(*)
 157       integer hethex(nbheto)
 158       integer hetpyr(nbpyto), npyrca(*)
 159       integer volqua(2,nbquto), pypequ(2,*)
 160       integer voltri(2,nbtrto), pypetr(2,*)
 161       integer nbpafo
 162 c
 163       double precision coonoe(nbnoto,sdim)
 164 c
 165       character*8 nopafo(*)
 166 c
 167       integer ulsost
 168       integer ulsort, langue, codret
 169 c
 170 c 0.4. ==> variables locales
 171 c
 172       integer nbfa, nbar, nbso
 173       parameter ( nbfa = 5, nbar = 9, nbso = 6 )
 174 c
 175       integer iaux, jaux, kaux
 176       integer numcal
 177       integer etat00, etat01, etatpe
 178       integer niveau, lafac1, lafac2, lafac3, lafac4, lafac5
 179       integer laface, lecode
 180       integer nbface
 181       integer freain, larete
 182       integer nbfipy, filspy
 183       integer nbfite, filste
 184       integer nbfipe
 185       integer listar(nbar), listso(nbso), volint(4,0:5)
 186       integer uldeb, ulfin, ulpas, ulecr
 187 c
 188       integer trav1a(tbdim), trav2a(tbdim)
 189 c
 190       character*40 taux40
 191 c
 192       double precision qualit, qualij, volume, diamet, torsio
 193       double precision vn(4)
 194 c
 195       integer nbmess
 196       parameter ( nbmess = 10 )
 197       character*80 texte(nblang,nbmess)
 198 c
 199 #include "fracte.h"
 200 c ______________________________________________________________________
 201 c
 202 c====
 203 c 1. initialisation
 204 c====
 205 c
 206 #include "impr01.h"
 207 #include "infoen.h"
 208 #include "tbdim1.h"
 209 c
 210 #ifdef _DEBUG_HOMARD_
 211       write (ulsort,texte(langue,1)) 'Entree', nompro
 212       call dmflsh (iaux)
 213 #endif
 214 c
 215       codret = 0
 216 c
 217       uldeb = min(ulsost,ulsort)
 218       ulfin = max(ulsost,ulsort)
 219       ulpas = max ( 1 , ulfin-uldeb )
 220 c
 221 c====
 222 c 2. numero du pentaedre dans HOMARD
 223 c====
 224 c
 225       if ( choix.eq.'PE' ) then
 226         iaux = lepent
 227         if ( lepent.gt.0 .and. lepent.le.repeac ) then
 228           lepent = npenho(iaux)
 229         else
 230           lepent = 0
 231         endif
 232       endif
 233 c
 234 c====
 235 c 3. reponses
 236 c====
 237 c
 238       do 30 , ulecr = uldeb , ulfin, ulpas
 239 c
 240       write (ulecr,40000)
 241 c
 242 c 3.1. ==> numero de pentaedre impossible
 243 c
 244       if ( lepent.le.0 .or. lepent.gt.nbpeto ) then
 245 c
 246         if ( choix.eq.'PE' ) then
 247           write (ulecr,40010) iaux
 248         else
 249           write (ulecr,40020) lepent
 250         endif
 251         write (ulecr,40030)
 252 c
 253 c 3.2. ==> numero de pentaedre correct
 254 c
 255       else
 256 c
 257         if ( repeac.gt.0 ) then
 258           numcal = npenca(lepent)
 259         else
 260           numcal = 0
 261         endif
 262         if ( numcal.ne.0 ) then
 263           write (ulecr,40020) lepent
 264           write (ulecr,40010) numcal
 265         else
 266           write (ulecr,40020) lepent
 267           write (ulecr,40040)
 268         endif
 269 c
 270 c 3.2.1. ==> Niveau
 271 c
 272         if ( lepent.le.nbpema ) then
 273           write (ulecr,41000)
 274         else
 275           if ( lepent.le.nbpecf ) then
 276             lafac1 = facpen(lepent,1)
 277             lafac2 = facpen(lepent,2)
 278             lafac3 = facpen(lepent,3)
 279             lafac4 = facpen(lepent,4)
 280             lafac5 = facpen(lepent,5)
 281             niveau = max(nivtri(lafac1),nivtri(lafac2),
 282      >                   nivqua(lafac3),nivqua(lafac4),nivqua(lafac5))
 283           endif
 284           if ( lepent.le.nbpepe ) then
 285             write (ulecr,41010) niveau
 286           else
 287             write (ulecr,41011) niveau-1
 288           endif
 289 c
 290         endif
 291 c
 292 c 3.2.2. ==> caracteristiques
 293 c
 294         write (ulecr,42000) fampen(lepent)
 295 c
 296 c 3.2.3. ==> les faces, les aretes et les noeuds
 297 c 3.2.3.1. ==> les faces
 298 c
 299         if ( lepent.le.nbpecf ) then
 300 c
 301           write (ulecr,43310)
 302           do 3231 , iaux = 1 , nbfa
 303             laface = facpen(lepent,iaux)
 304             lecode = cofape(lepent,iaux)
 305             if ( iaux.le.2 ) then
 306               taux40 = texttr(mod(hettri(laface),10))
 307             else
 308               taux40 = textqu(mod(hetqua(laface),100))
 309               laface = -laface
 310             endif
 311             write (ulecr,43320) laface, lecode, taux40
 312  3231     continue
 313 c
 314         endif
 315 c
 316 c 3.2.3.2. ==> les aretes et les sommets
 317 c
 318         call utaspe ( lepent,
 319      >                nbquto, nbpecf, nbpeca,
 320      >                somare, arequa,
 321      >                facpen, cofape, arepen,
 322      >                listar, listso )
 323 c
 324         write (ulecr,43030)
 325         do 3232 , iaux = 1 , nbar
 326           larete = listar(iaux)
 327           taux40 = textar(mod(hetare(larete),10))
 328           write (ulecr,43031) larete, taux40
 329  3232   continue
 330 c
 331         write (ulecr,43040)
 332         write (ulecr,50006) (listso(iaux),iaux=1,nbso)
 333 c
 334 c 3.2.3.3. ==> les noeuds au milieu des aretes
 335 c
 336         if ( degre.eq.2 ) then
 337 c
 338           write (ulecr,43050)
 339           write (ulecr,50009) (np2are(listar(iaux)),iaux=1,nbar)
 340 c
 341         endif
 342 c
 343 c 3.2.4. ==> etat
 344 c
 345         etat01 = mod(hetpen(lepent),100)
 346         etat00 = (hetpen(lepent)-etat01) / 100
 347 c
 348         taux40 = textpe(etat01)
 349         write (ulecr,44010)
 350         write (ulecr,40001) taux40
 351         if ( nbiter.ge.1 ) then
 352           taux40 = textpe(etat00)
 353           write (ulecr,44020)
 354           write (ulecr,40001) taux40
 355         endif
 356 c
 357 c 3.2.5. ==> la parente
 358 c 3.2.5.1. ==> les fils
 359 c
 360         if ( etat01.ne.0 ) then
 361 c
 362           freain = filpen(lepent)
 363 c
 364 c 3.2.5.1. ==> les fils
 365 c 3.2.5.1.1. ==> fils pour le decoupage de conformite
 366 c
 367           if ( ( etat01.ge. 1 .and. etat01.le. 6 ) .or.
 368      >         ( etat01.ge.17 .and. etat01.le.19 ) .or.
 369      >         ( etat01.ge.21 .and. etat01.le.26 ) .or.
 370      >         ( etat01.ge.31 .and. etat01.le.36 ) .or.
 371      >         ( etat01.ge.43 .and. etat01.le.45 ) .or.
 372      >         ( etat01.ge.51 .and. etat01.le.52 ) ) then
 373 c
 374             freain = -freain
 375             filspy = fppyte(1,freain)
 376             filste = fppyte(2,freain)
 377             if ( etat01.ge.1 .and. etat01.le.6 ) then
 378               nbfipy = 1
 379               nbfite = 0
 380             elseif ( etat01.ge.17 .and. etat01.le.19 ) then
 381               nbfipy = 0
 382               nbfite = 1
 383             elseif ( etat01.ge.21 .and. etat01.le.26 ) then
 384               nbfipy = -1
 385               nbfite = 5
 386             elseif ( etat01.ge.31 .and. etat01.le.36 ) then
 387               nbfipy = 0
 388               nbfite = 9
 389             elseif ( etat01.ge.43 .and. etat01.le.45 ) then
 390               nbfipy = 3
 391               nbfite = 1
 392             elseif ( etat01.ge.51 .and. etat01.le.52 ) then
 393               nbfipy = -1
 394               nbfite = 10
 395             else
 396               nbfipy = -1
 397               nbfite = -1
 398             endif
 399             if ( nbfipy.ge.0 ) then
 400               write (ulecr,45010) mess14(langst,3,5)
 401               do 3251 , jaux = 0 , nbfipy
 402                 kaux = filspy+jaux
 403                 write (ulecr,45080) kaux, npyrca(kaux)
 404  3251         continue
 405             endif
 406             if ( nbfite.ge.0 ) then
 407               write (ulecr,45010) mess14(langst,3,3)
 408               do 3252 , jaux = 0 , nbfite
 409                 kaux = filste+jaux
 410                 write (ulecr,45080) kaux, ntetca(kaux)
 411  3252         continue
 412             endif
 413 c
 414 c 3.2.5.1.2. ==> fils pour le decoupage standard
 415 c
 416           else
 417 c
 418             write (ulecr,45010) mess14(langst,3,7)
 419             nbfipe = 7
 420             do 3253 , jaux = 0 , nbfipe
 421               kaux = freain+jaux
 422               if ( repeac.eq.0 .or. npenca(kaux).eq.0 ) then
 423                 write (ulecr,45070) kaux
 424               else
 425                 write (ulecr,45080) kaux, npenca(kaux)
 426               endif
 427  3253       continue
 428           endif
 429 c
 430         endif
 431 c
 432 c 3.2.5.2 ==> pere
 433 c
 434         if ( perpen(lepent).ne.0 ) then
 435 c
 436           write (ulecr,45040) mess14(langst,1,7), perpen(lepent)
 437           etatpe = mod(hetpen(perpen(lepent)),100)
 438           if ( etatpe.eq.80 .or. etatpe.eq.99 ) then
 439             iaux = 7
 440           else
 441             codret = 3252
 442             goto 30
 443           endif
 444           freain = filpen(perpen(lepent))
 445           write (ulecr,45050) mess14(langst,3,7)
 446           do 3254 , jaux = 0 , iaux
 447             kaux = freain+jaux
 448             if ( kaux.ne.lepent ) then
 449               if ( repeac.eq.0 ) then
 450                 write (ulecr,45070) kaux
 451               else
 452                 write (ulecr,45080) kaux, npenca(kaux)
 453               endif
 454             endif
 455  3254     continue
 456 c
 457         endif
 458 c
 459 c 3.2.6. ==> les volumes voisins
 460 c 3.2.6.1. ==> on commence par dresser la liste de tous les pentaedres
 461 c              qui bordent les faces du pentaedre courant mais qui ne
 462 c              peuvent pas etre consideres comme des volumes voisins :
 463 c              lui-meme et ses fils dans les cas de conformite.
 464 c              il suffit d'eliminer les pyramides dont la base est une
 465 c              des faces quadrangulaires de l'hexaedre et les tetraedres
 466 c              s'appuyant sur une face triangulaire non decoupee.
 467 c              Dans les autres cas, le volume ne peut pas etre voisin
 468 c              du pentaedre.
 469 c              voir cmcdpe pour les conventions sur les fils
 470 c
 471         iaux = 0
 472         if ( etat01.ge.1 .and. etat01.le.9 ) then
 473           iaux = iaux + 1
 474           volint(1,iaux) = fppyte(2,-filpen(lepent))
 475         elseif ( etat01.ge.7 .and. etat01.le.9 ) then
 476           iaux = iaux + 1
 477           volint(1,iaux) = fppyte(2,-filpen(lepent))
 478           iaux = iaux + 1
 479           volint(1,iaux) = fppyte(2,-filpen(lepent)) + 1
 480         elseif ( etat01.ge.11 .and. etat01.le.16 ) then
 481           iaux = iaux + 1
 482           volint(1,iaux) = fppyte(2,-filpen(lepent))
 483         elseif ( etat01.ge.31 .and. etat01.le.32 ) then
 484           iaux = iaux + 1
 485           volint(1,iaux) = fppyte(2,-filpen(lepent)) + 10
 486         endif
 487         volint(1,0) = iaux
 488         volint(2,0) = 0
 489         iaux = 1
 490         if ( etat01.ge.1 .and. etat01.le.9 ) then
 491           iaux = iaux + 1
 492           volint(3,iaux) = fppyte(1,-filpen(lepent))
 493           iaux = iaux + 1
 494           volint(3,iaux) = fppyte(1,-filpen(lepent)) + 1
 495         elseif ( etat01.ge.7 .and. etat01.le.9 ) then
 496           iaux = iaux + 1
 497           volint(3,iaux) = fppyte(1,-filpen(lepent))
 498         elseif ( etat01.ge.21 .and. etat01.le.23 ) then
 499           iaux = iaux + 1
 500           volint(3,iaux) = fppyte(2,-filpen(lepent))
 501         endif
 502         volint(3,0) = iaux
 503         volint(4,iaux) = lepent
 504         volint(4,0) = iaux
 505 c
 506 c 3.2.6.2. ==> liste des faces a examiner
 507 c
 508         nbface = 0
 509 c
 510 c 3.2.6.2.1. ==> voisinage par les triangles
 511 c
 512         do 32621 , iaux = 1, 2
 513           if ( voltri(2,facpen(lepent,iaux)).ne.0 ) then
 514             nbface = nbface + 1
 515             trav2a(nbface) = facpen(lepent,iaux)
 516           endif
 517 32621   continue
 518 c
 519 c 3.2.6.2.2. ==> voisinage par les quadrangles
 520 c
 521         do 32622 , iaux = 3, 5
 522           if ( volqua(2,facpen(lepent,iaux)).ne.0 ) then
 523             nbface = nbface + 1
 524             trav2a(nbface) = -facpen(lepent,iaux)
 525           endif
 526 32622   continue
 527 c
 528 c 3.2.6.3. ==> impression
 529 c
 530 #ifdef _DEBUG_HOMARD_
 531       write (ulsort,texte(langue,3)) 'INFOVO', nompro
 532 #endif
 533         iaux = 40
 534         kaux = ulecr
 535         call infovo ( iaux, 1, nbface, volint,
 536      >                voltri, pypetr,
 537      >                volqua, pypequ,
 538      >                hettet, hetpyr, hethex, hetpen,
 539      >                trav1a, trav2a,
 540      >                kaux,
 541      >                ulsort, langue, codret )
 542 c
 543 c 3.2.7. ==> le centre de gravite
 544 c
 545         do 327 , iaux = 1 , sdim
 546           vn(iaux) = unssix * ( coonoe(listso(1),iaux) +
 547      >                          coonoe(listso(2),iaux) +
 548      >                          coonoe(listso(3),iaux) +
 549      >                          coonoe(listso(4),iaux) +
 550      >                          coonoe(listso(5),iaux) +
 551      >                          coonoe(listso(6),iaux) )
 552   327   continue
 553 c
 554         write (ulecr,49003) (vn(iaux), iaux = 1 , sdim)
 555 c
 556 c 3.2.8. ==> volume, qualite, diametre et torsion
 557 c
 558         call utqpen ( lepent, qualit, qualij, volume,
 559      >                coonoe, somare, arequa,
 560      >                facpen, cofape, arepen )
 561 c
 562         write (ulecr,49030) volume
 563 c
 564         write (ulecr,49041) qualij
 565 c
 566         call utdpen ( lepent, diamet,
 567      >                coonoe, somare, arequa,
 568      >                facpen, cofape, arepen )
 569 c
 570         write (ulecr,49050) diamet
 571 c
 572         call uttpen ( lepent, torsio,
 573      >                coonoe, somare, arequa,
 574      >                facpen, cofape, arepen )
 575 c
 576         write (ulecr,49060) torsio
 577 c
 578 c 3.2.9. ==> les valeurs des fonctions
 579 c
 580         if ( nbpafo.ne.0 .and. numcal.ne.0 ) then
 581 c
 582           if ( degre.eq.1 ) then
 583             iaux = edpen6
 584           else
 585             iaux = edpe15
 586           endif
 587           jaux = npencs(numcal)
 588           kaux = ulecr
 589 #ifdef _DEBUG_HOMARD_
 590       write (ulsort,texte(langue,3)) 'INFOPF', nompro
 591 #endif
 592           call infopf ( nbpafo, nopafo,
 593      >                  iaux, jaux,
 594      >                  kaux,
 595      >                  ulsort, langue, codret )
 596 c
 597         endif
 598 c
 599       endif
 600 c
 601       write (ulecr,40000)
 602 c
 603    30 continue
 604 c
 605 c===
 606 c 4. formats
 607 c===
 608 c
 609 40020 format(
 610      >  '* Pentaedre numero :',i10,   ' dans HOMARD                  *')
 611 c
 612 41000 format(
 613      >  '* . C''est un pentaedre du maillage initial.                 ',
 614      >  '*')
 615 c
 616 46110 format(
 617      >  '* . Il a un pentaedre voisin :                              *')
 618 46120 format(
 619      >  '* . Il est le voisin de ',i10,   ' pentaedres :             *')
 620 c
 621 c====
 622 c 5. La fin
 623 c====
 624 c
 625       if ( codret.ne.0 ) then
 626 c
 627 #include "envex2.h"
 628 c
 629       write (ulsort,texte(langue,1)) 'Sortie', nompro
 630       write (ulsort,texte(langue,2)) codret
 631 c
 632       endif
 633 c
 634 #ifdef _DEBUG_HOMARD_
 635       write (ulsort,texte(langue,1)) 'Sortie', nompro
 636       call dmflsh (iaux)
 637 #endif
 638 c
 639       end