src/tool/Utilitaire/utecf0.F

   1       subroutine utecf0 ( maextr, typenh, nbento,
   2      >                    nbfaen, nbfcf1, nbfcf2,
   3      >                    nctfen, ncffen, ncxfen, ncefen,
   4      >                    fament, cfaent,
   5      >                    ulsort, langue, codret )
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c    UTilitaire - ECriture des Codes de Familles d'entites - 0
  27 c    --           -            -        -                    -
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . maextr . e   .   1    . maillage extrude                           .
  33 c .        .     .        . 0 : non                                    .
  34 c .        .     .        . 1 : selon X                                .
  35 c .        .     .        . 2 : selon Y                                .
  36 c .        .     .        . 3 : selon Z (cas de Saturne ou Neptune)    .
  37 c . typenh . e   .    1   . type d'entites                             .
  38 c .        .     .        .  -1 : noeuds                               .
  39 c .        .     .        .   0 : mailles-points                       .
  40 c .        .     .        .   1 : segments                             .
  41 c .        .     .        .   2 : triangles                            .
  42 c .        .     .        .   3 : tetraedres                           .
  43 c .        .     .        .   3 : quadrangles                          .
  44 c .        .     .        .   5 : pyramides                            .
  45 c .        .     .        .   6 : hexaedres                            .
  46 c .        .     .        .   7 : pentaedres                           .
  47 c . nbento . e   .    1   . nombre d'entites                           .
  48 c . nbfaen . e   .    1   . nombre de familles enregistrees            .
  49 c . nbfcf1 . e   .    1   . nombre de familles pour la conformite - 1  .
  50 c . nbfcf2 . e   .    1   . nombre de familles pour la conformite - 2  .
  51 c . nctfen . e   .    1   . nombre total de caracteristiques familles  .
  52 c . ncefen . e   .    1   . nombre de caracteristiques d'equivalence   .
  53 c . ncffen . e   .    1   . nombre fige de caracteristiques            .
  54 c . fament . e   . nbento . famille des entites                        .
  55 c . cfaent . e   . nctfen*. codes des familles d'entites               .
  56 c .        .     . nbfaen .   1 : famille MED                          .
  57 c .        .     .        . si maille-point :                          .
  58 c .        .     .        .   2 : type de maille-point                 .
  59 c .        .     .        .   3 : famille des sommets                  .
  60 c .        .     .        . si arete :                                 .
  61 c .        .     .        .   2 : type de segment                      .
  62 c .        .     .        .   3 : orientation                          .
  63 c .        .     .        .   4 : famille d'orientation inverse        .
  64 c .        .     .        .   5 : numero de ligne de frontiere         .
  65 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  66 c .        .     .        . <= 0 si non concernee                      .
  67 c .        .     .        .   6 : famille frontiere active/inactive    .
  68 c .        .     .        .   7 : numero de surface de frontiere       .
  69 c .        .     .        . + l : appartenance a l'equivalence l       .
  70 c .        .     .        . si triangle :                              .
  71 c .        .     .        .   2 : type de triangle                     .
  72 c .        .     .        .   3 : numero de surface de frontiere       .
  73 c .        .     .        .   3 : famille des aretes internes apres raf.
  74 c .        .     .        . + l : appartenance a l'equivalence l       .
  75 c .        .     .        . si quadrangle :                            .
  76 c .        .     .        .   2 : type de quadrangle                   .
  77 c .        .     .        .   3 : numero de surface de frontiere       .
  78 c .        .     .        .   3 : famille des aretes internes apres raf.
  79 c .        .     .        .   5 : famille des triangles de conformite  .
  80 c .        .     .        .   6 : famille de sf active/inactive        .
  81 c .        .     .        . + l : appartenance a l'equivalence l       .
  82 c .        .     .        . si tetraedre, hexaedre, pyramide, pentaedre.
  83 c .        .     .        .   2 : type de mailles                      .
  84 c .        .     .        . si hexaedre :                              .
  85 c .        .     .        .   3 : famille des tetraedres de conformite .
  86 c .        .     .        .   3 : famille des pyramides de conformite  .
  87 c .        .     .        . si extrusion et noeud/arete/tria/quad :    .
  88 c .        .     .        . n+1 : famille du noeud extrude             .
  89 c .        .     .        . n+2 : famille de l'arete perpendiculaire   .
  90 c .        .     .        . si extrusion et triangle ou quadrangle :   .
  91 c .        .     .        . n+3 : code de la face dans le volume       .
  92 c .        .     .        . si extrusion :                             .
  93 c .        .     .        . n+3/4 : position de l'entite               .
  94 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  95 c . langue . e   .    1   . langue des messages                        .
  96 c .        .     .        . 1 : francais, 2 : anglais                  .
  97 c . codret . es  .    1   . code de retour des modules                 .
  98 c .        .     .        . 0 : pas de probleme                        .
  99 c .        .     .        . 1 : probleme                               .
 100 c ______________________________________________________________________
 101 c
 102 c====
 103 c 0. declarations et dimensionnement
 104 c====
 105 c
 106 c 0.1. ==> generalites
 107 c
 108       implicit none
 109       save
 110 c
 111       character*6 nompro
 112       parameter ( nompro = 'UTECF0' )
 113 c
 114 #include "nblang.h"
 115 #include "coftex.h"
 116 c
 117 c 0.2. ==> communs
 118 c
 119 #include "envex1.h"
 120 c
 121 #include "impr02.h"
 122 c
 123 c 0.3. ==> arguments
 124 c
 125       integer maextr
 126       integer typenh, nbento
 127       integer nbfaen, nbfcf1, nbfcf2
 128       integer nctfen, ncffen, ncxfen, ncefen
 129       integer fament(nbento)
 130       integer cfaent(nctfen,nbfaen)
 131 c
 132       integer ulsort, langue, codret
 133 c
 134 c 0.4. ==> variables locales
 135 c
 136       integer nbmi01, nbmi21, nbmx20, nbmx40, nbmxxx
 137       integer iaux, jaux, kaux
 138       integer nbenfa
 139       integer lgstar(-1:7)
 140 c
 141       character*80 saux80
 142 c
 143       integer nbmess
 144       parameter ( nbmess = 10 )
 145       character*80 texte(nblang,nbmess)
 146 c
 147 c 0.5. ==> initialisations
 148 c
 149       data lgstar / 33, 53, 93, 63, 43, 83, 43, 63, 63  /
 150 c ______________________________________________________________________
 151 c
 152 c====
 153 c 1. messages
 154 c====
 155 c
 156 #include "impr01.h"
 157 c
 158 #ifdef _DEBUG_HOMARD_
 159       write (ulsort,texte(langue,1)) 'Entree', nompro
 160       call dmflsh (iaux)
 161 #endif
 162 c
 163       texte(1,4) =
 164      > '(/,5x,123(''-''),/,/,5x,''Description des familles des '',a)'
 165       texte(1,5) = '(5x,''Nombre de familles          : '',i8)'
 166       texte(1,6) = '(5x,''Nombre de codes par famille : '',i3)'
 167 c
 168       texte(2,4) =
 169      > '(/,5x,123(''-''),/,/,5x,''Description of families of '',a)'
 170       texte(2,5) = '(5x,''Number of families        : '',i8)'
 171       texte(2,6) = '(5x,''Number of codes per family: '',i3)'
 172 c
 173 #include "impr03.h"
 174 c
 175       codret = 0
 176 c
 177 c====
 178 c 2. En tete
 179 c====
 180 c
 181       write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
 182 #ifdef _DEBUG_HOMARD_
 183       write (ulsort,texte(langue,5)) nbfaen
 184       write (ulsort,texte(langue,6)) nctfen
 185 #endif
 186 c
 187 #ifdef _DEBUG_HOMARD_
 188       write (ulsort,90002) 'nctfen, ncffen, ncxfen, ncefen',
 189      >                      nctfen, ncffen, ncxfen, ncefen
 190 #endif
 191 c
 192 c====
 193 c 3. Les familles
 194 c====
 195 c
 196       if ( nbfaen.gt.0 ) then
 197 c
 198 c 3.1. ==> les caracteristiques de base
 199 c 3.1.1. ==> sans extrusion
 200 c
 201         if ( maextr.eq.0 ) then
 202 c
 203           if ( nbfcf1.eq.0 .and. nbfcf2.eq.0 ) then
 204             kaux = 2
 205           else
 206             kaux = 0
 207           endif
 208 c
 209           if ( typenh.eq.-1 ) then
 210             write (ulsort,11001)
 211             write (ulsort,20090)
 212           elseif ( typenh.eq.0 ) then
 213             write (ulsort,11003)
 214             write (ulsort,30090)
 215           elseif ( typenh.eq.1 ) then
 216             write (ulsort,11007)
 217             write (ulsort,40090)
 218           elseif ( typenh.eq.2 ) then
 219             write (ulsort,11004)
 220             write (ulsort,50090)
 221           elseif ( typenh.eq.3 .or. typenh.eq.5 ) then
 222             write (ulsort,11002)
 223             write (ulsort,60090) mess14(1,3,typenh)(1:10)
 224           elseif ( typenh.eq.4 ) then
 225             write (ulsort,11006)
 226             write (ulsort,70090)
 227           elseif ( typenh.eq.6 .or. typenh.eq.7 ) then
 228             if ( nbfcf1.eq.0 .and. nbfcf2.eq.0 ) then
 229               write (ulsort,11002)
 230               write (ulsort,60090) mess14(1,3,typenh)(1:10)
 231               kaux = 2
 232             else
 233               write (ulsort,11004)
 234               write (ulsort,80090) mess14(1,3,typenh)(1:10)
 235             endif
 236           endif
 237 c
 238           do 311, iaux = 1, nbfaen
 239 c
 240             nbenfa = 0
 241             do 312, jaux = 1, nbento
 242               if ( fament(jaux).eq.iaux ) then
 243                 nbenfa = nbenfa + 1
 244               endif
 245   312       continue
 246             if ( typenh.eq.-1 ) then
 247               write (ulsort,12001) iaux, nbenfa,
 248      >                             (cfaent(jaux,iaux),jaux=1,ncffen)
 249             elseif ( typenh.eq.0 ) then
 250               write (ulsort,12003) iaux, nbenfa,
 251      >                             (cfaent(jaux,iaux),jaux=1,ncffen)
 252             elseif ( typenh.eq.1 ) then
 253               write (ulsort,12007) iaux, nbenfa,
 254      >                             (cfaent(jaux,iaux),jaux=1,ncffen)
 255             elseif ( typenh.eq.2 ) then
 256               write (ulsort,12004) iaux, nbenfa,
 257      >                             (cfaent(jaux,iaux),jaux=1,ncffen)
 258             elseif ( typenh.eq.3 .or. typenh.eq.5 ) then
 259               write (ulsort,12002) iaux, nbenfa,
 260      >                             (cfaent(jaux,iaux),jaux=1,ncffen)
 261             elseif ( typenh.eq.4 ) then
 262               write (ulsort,12006) iaux, nbenfa,
 263      >                             (cfaent(jaux,iaux),jaux=1,ncffen)
 264             elseif ( typenh.eq.6 .or. typenh.eq.7 ) then
 265               if ( kaux.eq.0 ) then
 266                 write (ulsort,12004) iaux, nbenfa,
 267      >                             (cfaent(jaux,iaux),jaux=1,ncffen)
 268               else
 269                 write (ulsort,12002) iaux, nbenfa,
 270      >                           (cfaent(jaux,iaux),jaux=1,ncffen-kaux)
 271               endif
 272             endif
 273 c
 274   311     continue
 275 c
 276           if ( typenh.eq.6 .or. typenh.eq.7 ) then
 277             if ( kaux.ne.0 ) then
 278               kaux = -2
 279             endif
 280           endif
 281 c
 282 c 3.1.2. ==> avec extrusion
 283 c            Remarque : ce sont seulement des noeuds, aretes,
 284 c                       triangles, quadrangles
 285 c
 286         else
 287 c
 288           if ( typenh.eq.-1 ) then
 289             write (ulsort,11004)
 290             write (ulsort,20091)
 291             kaux = 3
 292           elseif ( typenh.eq.1 ) then
 293             write (ulsort,11010)
 294             write (ulsort,40091)
 295             kaux = 3
 296           elseif ( typenh.eq.2 ) then
 297             write (ulsort,11008)
 298             write (ulsort,50091)
 299             kaux = 4
 300           elseif ( typenh.eq.4 ) then
 301             write (ulsort,11010)
 302             write (ulsort,70091)
 303             kaux = 4
 304           elseif ( typenh.eq.6 ) then
 305             write (ulsort,11003)
 306             write (ulsort,80091) mess14(1,3,typenh)(1:10)
 307             kaux = 1
 308           elseif ( typenh.eq.7 ) then
 309             write (ulsort,11002)
 310             write (ulsort,60090) mess14(1,3,typenh)(1:10)
 311             kaux = 2
 312           endif
 313 c
 314           do 313, iaux = 1, nbfaen
 315 c
 316             nbenfa = 0
 317             do 314, jaux = 1, nbento
 318               if ( fament(jaux).eq.iaux ) then
 319                 nbenfa = nbenfa + 1
 320               endif
 321   314       continue
 322             if ( typenh.eq.-1 ) then
 323               write (ulsort,12005) iaux, nbenfa,
 324      >                         (cfaent(jaux,iaux),jaux=1,ncffen+ncxfen)
 325             elseif ( typenh.eq.1 ) then
 326               write (ulsort,12010) iaux, nbenfa,
 327      >                         (cfaent(jaux,iaux),jaux=1,ncffen+ncxfen)
 328             elseif ( typenh.eq.2 ) then
 329               write (ulsort,12008) iaux, nbenfa,
 330      >                         (cfaent(jaux,iaux),jaux=1,ncffen+ncxfen)
 331             elseif ( typenh.eq.4 ) then
 332               write (ulsort,12010) iaux, nbenfa,
 333      >                         (cfaent(jaux,iaux),jaux=1,ncffen+ncxfen)
 334             elseif ( typenh.eq.6 ) then
 335               write (ulsort,12004) iaux, nbenfa,
 336      >                           (cfaent(jaux,iaux),jaux=1,ncffen-kaux)
 337             elseif ( typenh.eq.7 ) then
 338               write (ulsort,12004) iaux, nbenfa,
 339      >                           (cfaent(jaux,iaux),jaux=1,ncffen-kaux)
 340             endif
 341 c
 342   313     continue
 343 c
 344           if ( typenh.eq.6 ) then
 345             kaux = -1
 346           elseif ( typenh.eq.7 ) then
 347             kaux = -2
 348           endif
 349 c
 350         endif
 351 c
 352 c 3.1.3. ==> Ligne finale du tableau
 353 c
 354         saux80 = '(5x,   (''*''))'
 355         write(saux80(5:7),'(i3)') lgstar(typenh) + kaux*10
 356         write (ulsort,saux80)
 357 c
 358 c 3.2. ==> les eventuelles equivalences
 359 c
 360         if ( ncefen.gt.0 ) then
 361 c
 362           nbmi01 = ncffen +  1
 363           nbmi21 = nbmi01 + 20
 364           nbmx20 = ncffen + 20
 365           nbmx40 = nbmx20 + 20
 366           nbmxxx = nctfen
 367           write (ulsort,10020) (jaux,jaux=nbmi01,nbmx20)
 368           do 33, iaux = 1, nbfaen
 369             if ( ncefen.le.20 ) then
 370               write (ulsort,10091) iaux,
 371      >        (cfaent(jaux,iaux),jaux=nbmi01,nbmxxx),
 372      >        (-1,jaux=nbmxxx+1,nbmx20)
 373             else
 374               write (ulsort,10091) iaux,
 375      >        (cfaent(jaux,iaux),jaux=nbmi01,nbmx20)
 376               write (ulsort,10092) iaux,
 377      >        (cfaent(jaux,iaux),jaux=nbmi21,nbmxxx),
 378      >        (-1,jaux=nbmxxx+1,nbmx40)
 379             endif
 380    33     continue
 381           write (ulsort,10093)
 382 c
 383         endif
 384 c
 385       endif
 386 c
 387 c====
 388 c 4. formats
 389 c====
 390 c
 391 c formats communs
 392 c ---------------
 393 10020 format(
 394      >/,5x,74('*'),
 395      >/,5x,'* Num. code*',20i3,' *',
 396      >/,5x,74('*'),
 397      >/,5x,'* Num. de  *     Equivalence 0:non, 1:oui,',
 398      >     ' -1:equivalence non definie    *',
 399      >/,5x,'* Famille  *  1  2  3  3  5  6  7  8  9 10',
 400      >     ' 11 12 13 14 15 16 17 18 19 20 *',
 401      >/,5x,74('*'))
 402 10091 format(
 403      >  5x,'*',i8,'  *',20i3,' *')
 404 10092 format(
 405      >  5x,'*',8x,'  *',20i3,' *')
 406 10093 format(
 407      >  5x,74('*'))
 408 c
 409 11001 format(
 410      >/,5x,33('*'),
 411      >/,5x,'* Numero du code :    *    1    *',
 412      >/,5x,33('*'))
 413 11002 format(
 414      >/,5x,43('*'),
 415      >/,5x,'* Numero du code :    *    1    *    2    *'
 416      >/,5x,43('*'))
 417 11003 format(
 418      >/,5x,53('*'),
 419      >/,5x,'* Numero du code :    *    1    *    2    *    3    *'
 420      >/,5x,53('*'))
 421 11004 format(
 422      >/,5x,63('*'),
 423      >/,5x,'* Numero du code :    *    1    *    2    *    3    *',
 424      >     '    4    *',
 425      >/,5x,63('*'))
 426 11006 format(
 427      >/,5x,83('*'),
 428      >/,5x,'* Numero du code :    *    1    *    2    *    3    *',
 429      >     '    4    *    5    *    6    *',
 430      >/,5x,83('*'))
 431 11007 format(
 432      >/,5x,93('*'),
 433      >/,5x,'* Numero du code :    *    1    *    2    *    3    *',
 434      >     '    4    *    5    *    6    *    7    *',
 435      >/,5x,93('*'))
 436 11008 format(
 437      >/,5x,103('*'),
 438      >/,5x,'* Numero du code :    *    1    *    2    *    3    *',
 439      >     '    4    *    5    *    6    *    7    *    8    *',
 440      >/,5x,103('*'))
 441 11010 format(
 442      >/,5x,123('*'),
 443      >/,5x,'* Numero du code :    *    1    *    2    *    3    *',
 444      >     '    4    *    5    *    6    *    7    *    8    *',
 445      >     '    9    *   10    *',
 446      >/,5x,123('*'))
 447 c
 448 12001 format(
 449      >  5x,'*',i8,' *',i10,   ' *',i8 ,' *')
 450 12002 format(
 451      >  5x,'*',i8,' *',i10, 2(' *',i8),' *')
 452 12003 format(
 453      >  5x,'*',i8,' *',i10, 3(' *',i8),' *')
 454 12004 format(
 455      >  5x,'*',i8,' *',i10, 4(' *',i8),' *')
 456 12005 format(
 457      >  5x,'*',i8,' *',i10, 5(' *',i8),' *')
 458 12006 format(
 459      >  5x,'*',i8,' *',i10, 6(' *',i8),' *')
 460 12007 format(
 461      >  5x,'*',i8,' *',i10, 7(' *',i8),' *')
 462 12008 format(
 463      >  5x,'*',i8,' *',i10, 8(' *',i8),' *')
 464 12010 format(
 465      >  5x,'*',i8,' *',i10,10(' *',i8),' *')
 466 c
 467 c formats pour les familles de noeuds
 468 c -----------------------------------
 469 20090 format(
 470      >  5x,'* Num. de *  Nombre   * Famille *',
 471      >/,5x,'* Famille * de noeuds *   MED   *',
 472      >/,5x,33('*'))
 473 20091 format(
 474      >  5x,'* Num. de *  Nombre   * Famille * Famille * Famille *',
 475      >     ' Position*',
 476      >/,5x,'* Famille * de noeuds *   MED   *no. tran.*ligne ex.*',
 477      >     '         *',
 478      >/,5x,63('*'))
 479 c
 480 c formats pour les familles de mailles-points
 481 c -------------------------------------------
 482 30090 format(
 483      >  5x,'* Num. de *  Nombre   * Famille *  Type   * Famille *'
 484      >/,5x,'* Famille * ma.points *   MED   *         * sommets *',
 485      >/,5x,53('*'))
 486 c
 487 c formats pour les familles d'aretes
 488 c ----------------------------------
 489 40090 format(
 490      >  5x,'* Num. de *  Nombre   * Famille *  Type   * Orient. *',
 491      >     ' Famille *  Numero * Famille *  Numero *',
 492      >/,5x,'* Famille * d''aretes  *   MED   *         *         *',
 493      >     ' or. inv * ligne fr*front ina* surf. fr*',
 494      >/,5x,93('*'))
 495 40091 format(
 496      >  5x,'* Num. de *  Nombre   * Famille *  Type   * Orient. *',
 497      >     ' Famille *  Numero * Famille *  Numero *',
 498      >     ' Famille * Famille * Position*',
 499      >/,5x,'* Famille * d''aretes  *   MED   *         *         *',
 500      >     ' or. inv * ligne fr*front ina* surf. fr*',
 501      >     'ar. tran.* quad ex.*         *',
 502      >/,5x,123('*'))
 503 c
 504 c formats pour les familles de triangles
 505 c --------------------------------------
 506 50090 format(
 507      >  5x,'* Num. de *  Nombre   * Famille *  Type   *  Numero *',
 508      >     ' Fa. aret*',
 509      >/,5x,'* Famille * triangles *   MED   *         *  surface*',
 510      >     ' surface *',
 511      >/,5x,63('*'))
 512 50091 format(
 513      >  5x,'* Num. de *  Nombre   * Famille *  Type   *  Numero *',
 514      >     ' Fa. aret*',
 515      >     ' Famille * Famille *  Code   * Position*',
 516      >/,5x,'* Famille * triangles *   MED   *         *  surface*',
 517      >     ' surface *',
 518      >     'tr. tran.* pent ex.*tria/pent*         *',
 519      >/,5x,103('*'))
 520 c
 521 c formats pour les familles de tetraedres, pyramides
 522 c --------------------------------------------------
 523 60090 format(
 524      >  5x,'* Num. de *  Nombre   * Famille *  Type   *',
 525      >/,5x,'* Famille * ',a10,   '*   MED   *         *',
 526      >/,5x,43('*'))
 527 c
 528 c formats pour les familles de quadrangles
 529 c ----------------------------------------
 530 70090 format(
 531      >  5x,'* Num. de *  Nombre   * Famille *  Type   *  Numero *',
 532      >     ' Fa. aret* Fa. tria* Famille *',
 533      >/,5x,'* Famille * de quads. *   MED   *         *  surface*',
 534      >     ' surface * confor. *front ina*',
 535      >/,5x,83('*'))
 536 70091 format(
 537      >  5x,'* Num. de *  Nombre   * Famille *  Type   *  Numero *',
 538      >     ' Fa. aret* Fa. tria* Famille *',
 539      >     ' Fa. q tr* Fa. h ex*  Code   * Position*',
 540      >/,5x,'* Famille *   quads.  *   MED   *         *  surface*',
 541      >     ' surface * confor. *front ina*',
 542      >     '/normale1*/normale2*quad h/p *         *',
 543      >/,5x,123('*'))
 544 c
 545 c formats pour les familles d'hexaedres, pentaedres
 546 c -------------------------------------------------
 547 80090 format(
 548      >  5x,'* Num. de *  Nombre   * Famille *  Type   * Famille *',
 549      >     ' Famille *',
 550      >/,5x,'* Famille * ',a10,   '*   MED   *         *  tetr.  *',
 551      >     '  pyra.  *',
 552      >/,5x,63('*'))
 553 80091 format(
 554      >  5x,'* Num. de *  Nombre   * Famille *  Type   * Famille *',
 555      >/,5x,'* Famille * ',a10,   '*   MED   *         *  pent.  *',
 556      >/,5x,53('*'))
 557 c
 558 c====
 559 c 3. la fin
 560 c====
 561 c
 562       if ( codret.ne.0 ) then
 563 c
 564 #include "envex2.h"
 565 c
 566       write (ulsort,texte(langue,1)) 'Sortie', nompro
 567       write (ulsort,texte(langue,2)) codret
 568 c
 569       endif
 570 c
 571 #ifdef _DEBUG_HOMARD_
 572       write (ulsort,texte(langue,1)) 'Sortie', nompro
 573       call dmflsh (iaux)
 574 #endif
 575 c
 576       end