src/tool/Information/infopy.F

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