src/tool/Utilitaire/utahma.F

   1       subroutine utahma ( nomail, typnom, option,
   2      >                      sdim,   mdim,  degre, mailet, maconf,
   3      >                    homolo, hierar, rafdef,
   4      >                    nbmane, typcca, typsfr, maextr,
   5      >                    norenu,
   6      >                    nhnoeu, nhmapo, nharet,
   7      >                    nhtria, nhquad,
   8      >                    nhtetr, nhhexa, nhpyra, nhpent,
   9      >                    nhelig,
  10      >                    nhvois, nhsupe, nhsups,
  11      >                    ulsort, langue, codret )
  12 c ______________________________________________________________________
  13 c
  14 c                             H O M A R D
  15 c
  16 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  17 c
  18 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  19 c aupres des huissiers de justice Simart et Lavoir a Clamart
  20 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  21 c aupres des huissiers de justice
  22 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  23 c
  24 c    HOMARD est une marque deposee d'Electricite de France
  25 c
  26 c Copyright EDF 1996
  27 c Copyright EDF 1998
  28 c Copyright EDF 2002
  29 c Copyright EDF 2020
  30 c ______________________________________________________________________
  31 c
  32 c    UTilitaire - Allocation pour HOMARD - MAillage
  33 c    --           -               -        --
  34 c
  35 c    Branche InfoSupE :
  36 c       Tab1 : communs entiers
  37 c       Tab2 : type des elements
  38 c       Si le format externe est le format MED :
  39 c         Tab3 : tableau de la branche Famille.Attribut.Pointeur
  40 c         Tab4 : tableau de la branche Famille.Attribut
  41 c         Tab5 : tableau de la branche Famille.Groupe.Pointeur
  42 c         Tab6 : tableau de la branche Famille.Groupe.Taille
  43 c         Tab7 : tableau de la branche InfoGene.Pointeur
  44 c         Tab8 : tableau de la branche InfoGene.Taille
  45 c         Tab9 : tableau de la branche Famille.Numero
  46 c    Branche InfoSupS :
  47 c       Tab1 : commun de la date
  48 c       Si le format externe est le format MED :
  49 c         Tab2 : tableau de la branche Famille.Groupe.Table
  50 c         Tab3 : tableau de la branche InfoGene.Table
  51 c         Tab4 : tableau de la branche Famille.Nom
  52 c         Tab5 : tableau de la branche Equivalt.InfoGene
  53 c
  54 c ______________________________________________________________________
  55 c .        .     .        .                                            .
  56 c .  nom   . e/s . taille .           description                      .
  57 c .____________________________________________________________________.
  58 c . nomail . es  . char8  . nom de l'objet maillage homard             .
  59 c . typnom . e   .    1   . type du nom de l'objet maillage            .
  60 c .        .     .        . 0 : le nom est a creer automatiquement     .
  61 c .        .     .        . 1 : le nom est impose par l'appel          .
  62 c . option . e   .    1   . option de creation de l'objet maillage     .
  63 c .        .     .        . 1 : toutes les branches sont a creer       .
  64 c .        .     .        . 2x : sauf la branche RenuMail              .
  65 c . sdim   . e   .    1   . dimension de l'espace                      .
  66 c . mdim   . e   .    1   . dimension du maillage                      .
  67 c . degre  . e   .    1   . degre du maillage                          .
  68 c . maconf . e   .    1   . conformite du maillage                     .
  69 c .        .     .        .  0 : oui                                   .
  70 c .        .     .        .  1 : non-conforme avec au minimum 2 aretes .
  71 c .        .     .        .      non decoupees en 2 par face           .
  72 c .        .     .        .  2 : non-conforme avec 1 seul noeud pendant.
  73 c .        .     .        .      par arete                             .
  74 c .        .     .        .  3 : non-conforme fidele a l'indicateur    .
  75 c .        .     .        . -1 : conforme, avec des boites pour les    .
  76 c .        .     .        .      quadrangles, hexaedres et pentaedres  .
  77 c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
  78 c .        .     .        .      decoupee en 2 et des boites pour les  .
  79 c .        .     .        .       quadrangles, hexaedres et pentaedres .
  80 c .        .     .        . 10 : non-conforme sans autre connaissance  .
  81 c . homolo . e   .    1   . type de relations par homologues           .
  82 c .        .     .        . 0 : pas d'homologues                       .
  83 c .        .     .        . 1 : relations sur les noeuds               .
  84 c .        .     .        . 2 : relations sur les noeuds et les aretes .
  85 c .        .     .        . 3 : relations sur les noeuds, les aretes   .
  86 c .        .     .        .     et les triangles                       .
  87 c . hierar . e   .    1   . maillage hierarchique                      .
  88 c .        .     .        . 0 : non                                    .
  89 c .        .     .        . 1 : oui                                    .
  90 c . rafdef . e   .    1   . 0 : macro-maillage                         .
  91 c .        .     .        . 1 : le maillage est inchange               .
  92 c .        .     .        . 2 : le maillage est issu du raffinement pur.
  93 c .        .     .        .     d'un autre maillage                    .
  94 c .        .     .        . 3 : le maillage est issu du deraffinement  .
  95 c .        .     .        .     pur d'un autre maillage                .
  96 c .        .     .        . 4 : le maillage est issu de raffinement et .
  97 c .        .     .        .     de deraffinement d'un autre maillage   .
  98 c .        .     .        . 12 : le maillage est un maillage passe de  .
  99 c .        .     .        .      degre 1 a 2                           .
 100 c .        .     .        . 21 : le maillage est un maillage passe de  .
 101 c .        .     .        .      degre 2 a 1                           .
 102 c . nbmane . e   .    1   . nombre maximum de noeuds par element       .
 103 c . typcca . e   .   1    . type du code de calcul                     .
 104 c . typsfr . e   .   1    . type du suivi de frontiere                 .
 105 c .        .     .        . 0 : aucun                                  .
 106 c .        .     .        . 1 : maillage de degre 1, avec projection   .
 107 c .        .     .        .     des nouveaux sommets                   .
 108 c .        .     .        . 2 : maillage de degre 2, seuls les noeuds  .
 109 c .        .     .        .     P1 sont sur la frontiere ; les noeuds  .
 110 c .        .     .        .     P2 restent au milieu des P1            .
 111 c .        .     .        . 3 : maillage de degre 2, les noeuds P2     .
 112 c .        .     .        .     etant sur la frontiere                 .
 113 c . maextr . e   .   1    . maillage extrude                           .
 114 c .        .     .        . 0 : non                                    .
 115 c .        .     .        . 1 : selon X                                .
 116 c .        .     .        . 2 : selon Y                                .
 117 c .        .     .        . 3 : selon Z (cas de Saturne ou Neptune)    .
 118 c . mailet . e   .    1   . presence de mailles etendues               .
 119 c .        .     .        .  1 : aucune                                .
 120 c .        .     .        . 2x : TRIA7                                 .
 121 c .        .     .        . 3x : QUAD9                                 .
 122 c .        .     .        . 5x : HEXA27                                .
 123 c . norenu .   s . char8  . nom de la branche RenuMail                 .
 124 c . nhnoeu .   s . char8  . nom de la branche Noeud                    .
 125 c . nhmapo .   s . char8  . nom de la branche Ma_Point                 .
 126 c . nharet .   s . char8  . nom de la branche Arete                    .
 127 c . nhtria .  s  . char8  . nom de l'objet decrivant les triangles     .
 128 c . nhquad .  s  . char8  . nom de l'objet decrivant les quadrangles   .
 129 c . nhtetr .  s  . char8  . nom de l'objet decrivant les tetraedres    .
 130 c . nhhexa .  s  . char8  . nom de l'objet decrivant les hexaedres     .
 131 c . nhpyra .  s  . char8  . nom de l'objet decrivant les pyramides     .
 132 c . nhpent .  s  . char8  . nom de l'objet decrivant les pentaedres    .
 133 c . nhvois .   s . char8  . nom de la branche Voisins                  .
 134 c . nhsupe .  s  . char8  . informations supplementaires entieres      .
 135 c . nhsups .  s  . char8  . informations supplementaires caracteres 8  .
 136 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 137 c . langue . e   .    1   . langue des messages                        .
 138 c .        .     .        . 1 : francais, 2 : anglais                  .
 139 c . codret . es  .    1   . code de retour des modules                 .
 140 c .        .     .        . 0 : pas de probleme                        .
 141 c .        .     .        . -1 : mauvaise demande pour le type de nom  .
 142 c .        .     .        . autre : probleme dans l'allocation         .
 143 c ______________________________________________________________________
 144 c
 145 c====
 146 c 0. declarations et dimensionnement
 147 c====
 148 c
 149 c 0.1. ==> generalites
 150 c
 151       implicit none
 152       save
 153 c
 154       character*6 nompro
 155       parameter ( nompro = 'UTAHMA' )
 156 c
 157 #include "nblang.h"
 158 c
 159 c 0.2. ==> communs
 160 c
 161 #include "envex1.h"
 162 c
 163 c 0.3. ==> arguments
 164 c
 165       character*8 nomail
 166 c
 167       integer typnom, option
 168 c
 169       character*8 norenu
 170       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 171       character*8 nhtetr, nhhexa, nhpyra, nhpent
 172       character*8 nhelig
 173       character*8 nhvois, nhsupe, nhsups
 174 c
 175       integer   sdim,   mdim
 176       integer  degre, maconf, homolo, hierar
 177       integer rafdef, nbmane, typcca, typsfr, maextr
 178       integer mailet
 179 c
 180       integer ulsort, langue, codret
 181 c
 182 c 0.4. ==> variables locales
 183 c
 184       integer iaux, jaux, kaux
 185       integer codre1, codre2, codre3, codre4, codre5
 186       integer codre6, codre7, codre8, codre9
 187       integer codre0
 188 c
 189       integer nbmess
 190       parameter ( nbmess = 10 )
 191       character*80 texte(nblang,nbmess)
 192 c
 193 c 0.5. ==> initialisations
 194 c ______________________________________________________________________
 195 c
 196 c====
 197 c 1. messages
 198 c====
 199 c
 200 #include "impr01.h"
 201 c
 202 #ifdef _DEBUG_HOMARD_
 203       write (ulsort,texte(langue,1)) 'Entree', nompro
 204       call dmflsh (iaux)
 205 #endif
 206 c
 207       texte(1,4) = '(''Allocation d''''un objet maillage HOMARD'',/)'
 208       texte(1,5) = '(''Mauvaise demande de type de nom :'',i6)'
 209       texte(1,6) = '(''Probleme pour allouer l''''objet '',a8)'
 210       texte(1,7) = '(''Probleme pour allouer un objet temporaire.'')'
 211 c
 212       texte(2,4) = '(''Allocation of an object HOMARD mesh'',/)'
 213       texte(2,5) = '(''Bad request for the type of the name :'',i6)'
 214       texte(2,6) = '(''Problem while allocating object '',a8)'
 215       texte(2,7) = '(''Problem while allocating a temporary object.'')'
 216 c
 217 #include "impr03.h"
 218 c
 219 #ifdef _DEBUG_HOMARD_
 220       write(ulsort,texte(langue,4))
 221 #endif
 222 #ifdef _DEBUG_HOMARD_
 223       write (ulsort,90002) 'sdim  ', sdim
 224       write (ulsort,90002) 'mdim  ', mdim
 225       write (ulsort,90002) 'degre ', degre
 226       write (ulsort,90002) 'mailet', mailet
 227       write (ulsort,90002) 'maconf', maconf
 228       write (ulsort,90002) 'homolo', homolo
 229       write (ulsort,90002) 'hierar', hierar
 230       write (ulsort,90002) 'rafdef', rafdef
 231       write (ulsort,90002) 'nbmane', nbmane
 232       write (ulsort,90002) 'typcca', typcca
 233       write (ulsort,90002) 'typsfr', typsfr
 234       write (ulsort,90002) 'maextr', maextr
 235 #endif
 236 c
 237 c====
 238 c 2. allocation de la structure du maillage HOMARD
 239 c====
 240 c 2.1. ==> allocation de la tete du maillage HOMARD
 241 c
 242       if ( typnom.eq.0 ) then
 243 c
 244         call gmalot ( nomail, 'HOM_Mail', 0, iaux, codre1 )
 245         codret = abs(codre1)
 246 c
 247       elseif ( typnom.eq.1 ) then
 248 c
 249         call gmaloj ( nomail, 'HOM_Mail', 0, iaux, codre1 )
 250         codret = abs(codre1)
 251 c
 252       else
 253 c
 254         codret = -1
 255 c
 256       endif
 257 c
 258 c 2.2. ==> Attributs
 259 #ifdef _DEBUG_HOMARD_
 260       write (ulsort,*) '2.2. attributs ; codret = ', codret
 261 #endif
 262 c
 263       if ( codret.eq.0 ) then
 264 c
 265       call gmecat ( nomail, 1, sdim, codre1 )
 266       call gmecat ( nomail, 2, mdim, codre2 )
 267       call gmecat ( nomail, 3, degre, codre3 )
 268       call gmecat ( nomail, 4, maconf, codre4 )
 269       call gmecat ( nomail, 5, homolo, codre5 )
 270 c
 271       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 272       codret = max ( abs(codre0), codret,
 273      >               codre1, codre2, codre3, codre4, codre5 )
 274 c
 275       call gmecat ( nomail, 6, hierar, codre1 )
 276       call gmecat ( nomail, 7, rafdef, codre2 )
 277       call gmecat ( nomail, 8, nbmane, codre3 )
 278       call gmecat ( nomail, 9, typcca, codre4 )
 279 c
 280       codre0 = min ( codre1, codre2, codre3, codre4 )
 281       codret = max ( abs(codre0), codret,
 282      >               codre1, codre2, codre3, codre4 )
 283 c
 284       call gmecat ( nomail,10, typsfr, codre1 )
 285       call gmecat ( nomail,11, maextr, codre2 )
 286 c
 287       codre0 = min ( codre1, codre2 )
 288       codret = max ( abs(codre0), codret,
 289      >               codre1, codre2 )
 290 c
 291       endif
 292 c
 293 c====
 294 c 3. Allocation des branches principales
 295 c====
 296 #ifdef _DEBUG_HOMARD_
 297       write (ulsort,*) '3. branches principales ; codret = ', codret
 298 #endif
 299 c
 300 c 3.1. ==> Allocation des branches principales
 301 c
 302       if ( codret.eq.0 ) then
 303 c
 304       call gmaloj ( nomail//'.Noeud'   , ' ', 0, iaux, codre1 )
 305       call gmaloj ( nomail//'.Ma_Point', ' ', 0, iaux, codre2 )
 306       call gmaloj ( nomail//'.Arete'   , ' ', 0, iaux, codre3 )
 307       call gmaloj ( nomail//'.Face'    , ' ', 0, iaux, codre4 )
 308       call gmaloj ( nomail//'.Volume'  , ' ', 0, iaux, codre5 )
 309       call gmaloj ( nomail//'.ElemIgno', ' ', 0, iaux, codre6 )
 310       call gmaloj ( nomail//'.Voisins' , ' ', 0, iaux, codre7 )
 311 c
 312       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 313      >               codre6, codre7 )
 314       codret = max ( abs(codre0), codret,
 315      >               codre1, codre2, codre3, codre4, codre5,
 316      >               codre6, codre7 )
 317 c
 318       call gmaloj ( nomail//'.InfoSupE', ' ', 0, iaux, codre1 )
 319       call gmaloj ( nomail//'.InfoSupS', ' ', 0, iaux, codre2 )
 320 c
 321       codre0 = min ( codre1, codre2 )
 322       codret = max ( abs(codre0), codret,
 323      >               codre1, codre2 )
 324 c
 325       endif
 326 c
 327 c 3.2. ==> Allocation des branches optionnelles
 328 c
 329       if ( codret.eq.0 ) then
 330 c
 331       if ( mod(option,2).ne.0 ) then
 332 c
 333         call gmaloj ( nomail//'.RenuMail', ' ', 0, iaux, codre0 )
 334 c
 335         codret = max ( abs(codre0), codret )
 336 c
 337         if ( codret.eq.0 ) then
 338 c
 339         call gmaloj ( nomail//'.RenuMail.InfoSupE',
 340      >                ' ', 0, iaux, codre1 )
 341         codre2 = 0
 342         do 32 , iaux = 1 , 10
 343           call gmecat ( nomail//'.RenuMail.InfoSupE', iaux, 0, codre0 )
 344           codre2 = max ( abs(codre2), codre0 )
 345    32   continue
 346 c
 347         codre0 = min ( codre1, codre2 )
 348         codret = max ( abs(codre0), codret,
 349      >                 codre1, codre2 )
 350 c
 351         endif
 352 c
 353       endif
 354 c
 355       endif
 356 c
 357 c====
 358 c 4. branches decrivant les elements
 359 c    on le fait pour un nombre nul d'elements
 360 c====
 361 #ifdef _DEBUG_HOMARD_
 362       write (ulsort,*) '4. branches des elements ; codret = ', codret
 363 #endif
 364 c 4.1. ==> allocation
 365 c
 366       jaux = 0
 367 c
 368       if ( codret.eq.0 ) then
 369 c
 370       if ( degre.eq.1 ) then
 371         call gmaloj (nomail//'.Arete.HOM_Se02' , ' ', jaux, iaux,codre1)
 372         call gmaloj (nomail//'.Face.HOM_Tr03'  , ' ', jaux, iaux,codre2)
 373         call gmaloj (nomail//'.Face.HOM_Qu04'  , ' ', jaux, iaux,codre3)
 374         call gmaloj (nomail//'.Volume.HOM_Te04', ' ', jaux, iaux,codre4)
 375         call gmaloj (nomail//'.Volume.HOM_He08', ' ', jaux, iaux,codre5)
 376         call gmaloj (nomail//'.Volume.HOM_Py05', ' ', jaux, iaux,codre6)
 377         call gmaloj (nomail//'.Volume.HOM_Pe06', ' ', jaux, iaux,codre7)
 378       else
 379         call gmaloj (nomail//'.Arete.HOM_Se03' , ' ', jaux, iaux,codre1)
 380         if ( mod(mailet,2).eq.0 .or. mod(mailet,3).eq.0 ) then
 381           call gmaloj (nomail//'.Face.HOM_Tr07', ' ', jaux, iaux,codre2)
 382         else
 383           call gmaloj (nomail//'.Face.HOM_Tr06', ' ', jaux, iaux,codre2)
 384         endif
 385         if ( mod(mailet,3).eq.0 ) then
 386           call gmaloj (nomail//'.Face.HOM_Qu09', ' ', jaux, iaux,codre3)
 387         else
 388           call gmaloj (nomail//'.Face.HOM_Qu08', ' ', jaux, iaux,codre3)
 389         endif
 390         call gmaloj (nomail//'.Volume.HOM_Te10', ' ', jaux, iaux,codre4)
 391         if ( mod(mailet,5).eq.0 ) then
 392           call gmaloj (nomail//'.Volume.HOM_He27',
 393      >                  ' ', jaux, iaux, codre5)
 394         else
 395           call gmaloj (nomail//'.Volume.HOM_He20',
 396      >                  ' ', jaux, iaux, codre5)
 397         endif
 398         call gmaloj (nomail//'.Volume.HOM_Py13', ' ', jaux, iaux,codre6)
 399         call gmaloj (nomail//'.Volume.HOM_Pe15', ' ', jaux, iaux,codre7)
 400       endif
 401 c
 402       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 403      >               codre6, codre7 )
 404       codret = max ( abs(codre0), codret,
 405      >               codre1, codre2, codre3, codre4, codre5,
 406      >               codre6, codre7 )
 407 c
 408       endif
 409 c
 410 c 4.2. ==> nom interne de ces branches
 411 #ifdef _DEBUG_HOMARD_
 412       write (ulsort,*) '4.2. nom interne ; codret = ', codret
 413 #endif
 414 c
 415       if ( codret.eq.0 ) then
 416 c
 417 #ifdef _DEBUG_HOMARD_
 418       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 419 #endif
 420       call utnomh ( nomail,
 421      >                sdim,   mdim,
 422      >               degre, maconf, homolo, hierar,
 423      >              rafdef, nbmane, typcca, typsfr, maextr,
 424      >              mailet,
 425      >              norenu,
 426      >              nhnoeu, nhmapo, nharet,
 427      >              nhtria, nhquad,
 428      >              nhtetr, nhhexa, nhpyra, nhpent,
 429      >              nhelig,
 430      >              nhvois, nhsupe, nhsups,
 431      >              ulsort, langue, codret)
 432 c
 433       endif
 434 c
 435 c 4.3. ==> on met un nombre nul de mailles a priori
 436 #ifdef _DEBUG_HOMARD_
 437       write (ulsort,*) '4.3 ; codret = ', codret
 438 #endif
 439 c
 440       jaux = 0
 441 c
 442       do 43 , iaux = 1 , 2
 443 c
 444         if ( codret.eq.0 ) then
 445 c
 446         call gmecat ( nhmapo, iaux, jaux, codre1 )
 447         call gmecat ( nharet, iaux, jaux, codre2 )
 448         call gmecat ( nhtria, iaux, jaux, codre3 )
 449         call gmecat ( nhtetr, iaux, jaux, codre4 )
 450         call gmecat ( nhquad, iaux, jaux, codre5 )
 451         call gmecat ( nhpyra, iaux, jaux, codre6 )
 452         call gmecat ( nhhexa, iaux, jaux, codre7 )
 453         call gmecat ( nhpent, iaux, jaux, codre8 )
 454 c
 455         codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 456      >                 codre6, codre7, codre8 )
 457         codret = max ( abs(codre0), codret,
 458      >                 codre1, codre2, codre3, codre4, codre5,
 459      >                 codre6, codre7, codre8 )
 460 c
 461         endif
 462 c
 463    43 continue
 464 c
 465       call gmecat ( nhelig, 1, jaux, codre0 )
 466       codret = max ( abs(codre0), codret )
 467 c
 468 c 4.4. ==> idem en renumerotation
 469 #ifdef _DEBUG_HOMARD_
 470       write (ulsort,*) '4.4 ; codret = ', codret
 471 #endif
 472 c
 473       if ( codret.eq.0 ) then
 474 c
 475       if ( mod(option,2).ne.0 ) then
 476 c
 477         do 44 , iaux = 1 , 19
 478 c
 479           jaux = iaux
 480           kaux = 0
 481           call gmecat ( norenu, jaux, kaux, codre0 )
 482 c
 483           codret = max ( abs(codre0), codret )
 484 c
 485    44   continue
 486 c
 487       endif
 488 c
 489       endif
 490 c
 491 c====
 492 c 5. allocation de la branche des familles
 493 c====
 494 #ifdef _DEBUG_HOMARD_
 495       write (ulsort,*) '5. familles ; codret = ', codret
 496 #endif
 497 c
 498       if ( codret.eq.0 ) then
 499 c
 500       call gmaloj ( nhnoeu//'.Famille', ' ', 0, iaux, codre1 )
 501       call gmaloj ( nhmapo//'.Famille', ' ', 0, iaux, codre2 )
 502       call gmaloj ( nharet//'.Famille', ' ', 0, iaux, codre3 )
 503       call gmaloj ( nhtria//'.Famille', ' ', 0, iaux, codre4 )
 504       call gmaloj ( nhtetr//'.Famille', ' ', 0, iaux, codre5 )
 505       call gmaloj ( nhquad//'.Famille', ' ', 0, iaux, codre6 )
 506       call gmaloj ( nhpyra//'.Famille', ' ', 0, iaux, codre7 )
 507       call gmaloj ( nhhexa//'.Famille', ' ', 0, iaux, codre8 )
 508       call gmaloj ( nhpent//'.Famille', ' ', 0, iaux, codre9 )
 509 c
 510       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 511      >               codre6, codre7, codre8, codre9 )
 512       codret = max ( abs(codre0), codret,
 513      >               codre1, codre2, codre3, codre4, codre5,
 514      >               codre6, codre7, codre8, codre9 )
 515 c
 516       endif
 517 c
 518 c====
 519 c 6. allocation des branches decrivant les voisinages
 520 c====
 521 #ifdef _DEBUG_HOMARD_
 522       write (ulsort,*) '5. voisinages ; codret = ', codret
 523 #endif
 524 c
 525       if ( codret.eq.0 ) then
 526 c
 527       call gmaloj ( nhvois//'.0D/1D' , ' ', 0, iaux, codre1 )
 528       call gmaloj ( nhvois//'.1D/2D' , ' ', 0, iaux, codre2 )
 529 c
 530       codre0 = min ( codre1, codre2 )
 531       codret = max ( abs(codre0), codret,
 532      >               codre1, codre2 )
 533 c
 534       endif
 535 c
 536 c====
 537 c 7. attributs nuls pour les informations supplementaires
 538 c====
 539 #ifdef _DEBUG_HOMARD_
 540       write (ulsort,*) '5. infos supplementaires ; codret = ', codret
 541 #endif
 542 c
 543       if ( codret.eq.0 ) then
 544 c
 545       do 71 , iaux = 1 , 10
 546         call gmecat ( nomail//'.InfoSupE' , iaux, 0, codre1 )
 547         call gmecat ( nomail//'.InfoSupS' , iaux, 0, codre2 )
 548         codre0 = min ( codre1, codre2 )
 549         codret = max ( abs(codre0), codret,
 550      >                 codre1, codre2 )
 551    71 continue
 552 c
 553       endif
 554 c
 555 #ifdef _DEBUG_HOMARD_
 556 c
 557 c====
 558 c 8. impression du graphe
 559 c====
 560 c
 561       call gmprsx (nompro, nomail )
 562       call gmprsx (nompro, nomail//'.Arete' )
 563       call gmprsx (nompro, nomail//'.Face' )
 564       call gmprsx (nompro, nomail//'.Volume' )
 565       call gmprsx (nompro, nomail//'.Voisins' )
 566       call gmprsx (nompro, nomail//'.InfoSupE' )
 567       call gmprsx (nompro, nomail//'.InfoSupS' )
 568 #endif
 569 c
 570 c====
 571 c 9. la fin
 572 c====
 573 c
 574       if ( codret.ne.0 ) then
 575 c
 576 #include "envex2.h"
 577 c
 578       write (ulsort,texte(langue,1)) 'Sortie', nompro
 579       write (ulsort,texte(langue,2)) codret
 580       if ( codret.eq.-1 ) then
 581         write (ulsort,texte(langue,5)) typnom
 582       else
 583         if ( typnom.eq.1 ) then
 584           write (ulsort,texte(langue,6)) nomail
 585         else
 586           write (ulsort,texte(langue,7))
 587         endif
 588       endif
 589 c
 590       endif
 591 c
 592 #ifdef _DEBUG_HOMARD_
 593       write (ulsort,texte(langue,1)) 'Sortie', nompro
 594       call dmflsh (iaux)
 595 #endif
 596 c
 597       end