src/tool/Information/infc02.F

   1       subroutine infc02 ( numcas,
   2      >                    typenh, nhenti, nbenti, nbentf, nbenta,
   3      >                    nbtvch, nutvch,
   4      >                    nbcomp, nbench, typgeo,
   5      >                    obcham, nupafo, infopf,
   6      >                    nhnoeu, nharet, nhtria, nhquad,
   7      >                    nhhexa, nhpent, norenu,
   8      >                    caraen, carare, caraca,
   9      >                    npenrc, entrec,
  10      >                    ulsort, langue, codret )
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c  INformation - inFormations Complementaires - phase 02
  31 c  --              -          -                       --
  32 c ______________________________________________________________________
  33 c  Creation de la fonction et du paquet
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . numcas . e   .   1    . numero du cas en cours de traitement       .
  39 c .        .     .        . 1 : niveau                                 .
  40 c .        .     .        . 2 : qualite                                .
  41 c .        .     .        . 3 : diametre                               .
  42 c .        .     .        . 4 : parente                                .
  43 c .        .     .        . 5 : voisins des recollements               .
  44 c . typenh . e   .   1    . type d'entites concernees                  .
  45 c .        .     .        . 0 : noeuds                                 .
  46 c .        .     .        . 1 : aretes                                 .
  47 c .        .     .        . 2 : triangles                              .
  48 c .        .     .        . 3 : tetraedres                             .
  49 c .        .     .        . 4 : quadrangles                            .
  50 c .        .     .        . 5 : pyramides                              .
  51 c .        .     .        . 6 : hexaedres                              .
  52 c .        .     .        . 7 : pentaedres                             .
  53 c . nhenti . e   . char*8 . structure de l'entite                      .
  54 c . nbenti . e   .   1    . nombre total d'entites concernees          .
  55 c . nbentf . e   .   1    . nombre d'entites concernees - par faces    .
  56 c . nbenta . e   .   1    . nombre d'entites concernees - par aretes   .
  57 c . nbtvch . e   .   1    . nombre de tableaux associes                .
  58 c . nutvch . e   .   1    . numero du tableau en cours                 .
  59 c . nbcomp . e   .   1    . nombre de composantes                      .
  60 c . nbench . e   .   1    . nombre d'entites du champ                  .
  61 c . typgeo . e   .   1    . type geometrique au sens med               .
  62 c . obcham . e   .   1    . nom de l'objet InfoCham associe            .
  63 c . infopf . e   .   *    . informations sur les paquets de fonctions  .
  64 c . nhnoeu . e   . char8  . nom de l'objet decrivant les noeuds        .
  65 c . nharet . e   . char8  . nom de l'objet decrivant les aretes        .
  66 c . nhtria . e   . char8  . nom de l'objet decrivant les triangles     .
  67 c . nhquad . e   . char8  . nom de l'objet decrivant les quadrangles   .
  68 c . nhhexa . e   . char8  . nom de l'objet decrivant les hexaedres     .
  69 c . nhpent . e   . char8  . nom de l'objet decrivant les pentaedres    .
  70 c . norenu . e   . char8  . nom de la branche Renum du maillage HOMARD .
  71 c . caraen . e   . nbinec*. caracteristiques entieres des tableaux du  .
  72 c .        .     . nbtvch . champ en cours d'examen                    .
  73 c .        .     .        . 1. type de support au sens MED             .
  74 c .        .     .        .  -1, si on prend tous les supports         .
  75 c .        .     .        . 2. numero du pas de temps                  .
  76 c .        .     .        . 3. numero d'ordre                          .
  77 c .        .     .        . 4. nombre de points de Gauss               .
  78 c .        .     .        . 5. nombre d'entites support                .
  79 c .        .     .        . 6. nombre de valeurs du profil eventuel    .
  80 c .        .     .        . 7. nombre de supports associes             .
  81 c .        .     .        . 8. 1, si aux noeuds par elements           .
  82 c .        .     .        .    2, si aux points de Gauss, associe avec .
  83 c .        .     .        .       un champ aux noeuds par elements     .
  84 c .        .     .        .    3, si aux points de Gauss autonome      .
  85 c .        .     .        .    0, sinon                                .
  86 c .        .     .        . 9. numero du 1er tableau dans la fonction  .
  87 c .        .     .        . 10. si champ elga, numero du champ elno    .
  88 c .        .     .        .     si champ elno, numero du champ elga si .
  89 c .        .     .        .     il existe, sinon -1                    .
  90 c .        .     .        . 11. type interpolation                     .
  91 c .        .     .        .       0, si automatique                    .
  92 c .        .     .        .       1 si degre 1, 2 si degre 2,          .
  93 c .        .     .        .       3 si iso-P2                          .
  94 c .        .     .        . 12. type de champ edfl64/edin64            .
  95 c .        .     .        . 21-nbinec. type des supports associes      .
  96 c . carare . e   . nbtvch . caracteristiques reelles du champ          .
  97 c .        .     .        . 1. valeur du pas de temps                  .
  98 c . caraca . e   . nbincc*. caracteristiques caracteres des tableaux   .
  99 c .        .     . nbsqch . du champ en cours d'examen                 .
 100 c .        .     .        . 1. nom de l'objet fonction                 .
 101 c .        .     .        . 2. nom de l'objet profil, blanc sinon      .
 102 c .        .     .        . 3. nom de l'objet localisation des points  .
 103 c .        .     .        . de Gauss, blanc sinon                      .
 104 c . npenrc . e   .  2*x   . nombre de paires d'entites recollees       .
 105 c . entrec . e   .2*npenrc. paires des entites voisines faces a recol. .
 106 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 107 c . langue . e   .    1   . langue des messages                        .
 108 c .        .     .        . 1 : francais, 2 : anglais                  .
 109 c . codret . es  .    1   . code de retour des modules                 .
 110 c .        .     .        . 0 : pas de probleme                        .
 111 c .        .     .        . 5 : mauvais type de code de calcul associe .
 112 c ______________________________________________________________________
 113 c
 114 c====
 115 c 0. declarations et dimensionnement
 116 c====
 117 c
 118 c 0.1. ==> generalites
 119 c
 120       implicit none
 121       save
 122 c
 123       character*6 nompro
 124       parameter ( nompro = 'INFC02' )
 125 c
 126 #include "nblang.h"
 127 #include "consts.h"
 128 #include "esutil.h"
 129 c
 130 c 0.2. ==> communs
 131 c
 132 #include "gmenti.h"
 133 #include "gmreel.h"
 134 #include "gmstri.h"
 135 #include "nombsr.h"
 136 c
 137 #include "nombhe.h"
 138 #include "nombpe.h"
 139 c
 140 #include "envex1.h"
 141 #include "impr02.h"
 142 c
 143 c 0.3. ==> arguments
 144 c
 145       integer numcas
 146       integer typenh, nbenti, nbentf, nbenta
 147       integer nbtvch, nutvch, nupafo
 148       integer nbcomp, nbench, typgeo
 149       integer caraen(nbinec,nbtvch)
 150 c
 151       integer npenrc, entrec(2,npenrc)
 152 c
 153       double precision carare(nbtvch)
 154 c
 155       character*8 nhenti
 156       character*8 nhnoeu, nharet, nhtria, nhquad
 157       character*8 nhhexa, nhpent, norenu
 158       character*8 infopf(*)
 159       character*8 obcham
 160       character*8 caraca(nbincc,nbtvch)
 161 c
 162       integer ulsort, langue, codret
 163 c
 164 c 0.4. ==> variables locales
 165 c
 166 #include "meddc0.h"
 167 c
 168       integer iaux, jaux
 169       integer adhist, adcode, adinsu, adcoar, admere, adins2
 170       integer pcoono
 171       integer phetar, psomar, pmerar
 172       integer phettr, paretr, ppertr, pnivtr
 173       integer phetqu, parequ, pperqu, pnivqu
 174       integer phethe, pquahe
 175       integer phetpe, pfacpe
 176       integer adencn
 177 c
 178       integer ngauss, nbtyas
 179       integer carsup, typint, typcha
 180       integer nbvapr
 181       integer advale, advalr, adobch, adprpg, adtyas
 182       integer adobfo, adtyge
 183       integer adprof, advatt
 184 c
 185       integer codre1, codre2
 186       integer codre0
 187 c
 188       character*8 nofonc, nopafo
 189       character*8 ntrav1, ntrav2
 190 c
 191       integer nbmess
 192       parameter ( nbmess = 10 )
 193       character*80 texte(nblang,nbmess)
 194 c
 195 c 0.5. ==> initialisations
 196 c ______________________________________________________________________
 197 c
 198 c====
 199 c 1. messages
 200 c====
 201 c
 202 #include "impr01.h"
 203 #include "impr03.h"
 204 c
 205 #ifdef _DEBUG_HOMARD_
 206       write (ulsort,texte(langue,1)) 'Entree', nompro
 207       call dmflsh (iaux)
 208 #endif
 209       texte(1,4) = '(''.. Examen des'',i10,1x,a)'
 210       texte(1,5) = '(''.. Nombre de tableau du champ :'',i10)'
 211 c
 212       texte(2,4) = '(''.. Examination of the'',i10,1x,a)'
 213       texte(2,5) = '(''.. Number of arrays for this field:'',i10)'
 214 c
 215 #ifdef _DEBUG_HOMARD_
 216       write (ulsort,texte(langue,4)) nbench, mess14(langue,3,typenh)
 217       write (ulsort,texte(langue,5)) nbtvch
 218       write (ulsort,90002) 'numcas', numcas
 219 #endif
 220 c
 221       codret = 0
 222 c
 223 c====
 224 c 2. Decodage de la structure
 225 c====
 226 c 2.1. ==> La structure principale
 227 c
 228       if ( codret.eq.0 ) then
 229 c
 230       if ( typenh.ne.2 .and. typenh.ne.4 ) then
 231 c
 232         iaux = 2
 233         if ( typenh.eq.3 .or. typenh.eq.5 .or.
 234      >       typenh.eq.6 .or. typenh.eq.7 ) then
 235           iaux = iaux*5*13
 236 c         quand des hexaedres et/ou des pentaedres sont coupes par
 237 c         conformite, il faut recuperer un tableau sur les parentes
 238 c         pour les tetraedres et les pyramides
 239           if ( ( typenh.eq.3 .or. typenh.eq.5 ) .and.
 240      >         ( nbheco.gt.0 .or. nbpeco.gt.0 ) ) then
 241             iaux = iaux*17
 242           endif
 243         endif
 244         if ( nbenta.gt.0 ) then
 245           iaux = iaux*31
 246         endif
 247 #ifdef _DEBUG_HOMARD_
 248         write (ulsort,texte(langue,3)) 'UTAD02_'//mess14(1,5,typenh),
 249      >                                  nompro
 250 #endif
 251         call utad02 (   iaux, nhenti,
 252      >                adhist, adcode,   jaux, admere,
 253      >                  jaux,   jaux,   jaux,
 254      >                  jaux, adinsu, adins2,
 255      >                  jaux,   jaux, adcoar,
 256      >                ulsort, langue, codret )
 257 c
 258       endif
 259 c
 260       endif
 261 c
 262 c 2.2. ==> Les coordonnees des noeuds si besoin
 263 c
 264 #ifdef _DEBUG_HOMARD_
 265       write (ulsort,90002) '2.2. noeuds ; codret', codret
 266 #endif
 267 c
 268       if ( codret.eq.0 ) then
 269 c
 270       if ( numcas.eq.2 .or. numcas.eq.3 ) then
 271 c
 272 #ifdef _DEBUG_HOMARD_
 273       write (ulsort,texte(langue,3)) 'UTAD01', nompro
 274 #endif
 275         iaux = 3
 276         call utad01 ( iaux, nhnoeu,
 277      >                  jaux,
 278      >                    jaux,   jaux,   jaux,
 279      >                pcoono,   jaux,   jaux,  jaux,
 280      >                ulsort, langue, codret )
 281 c
 282       endif
 283 c
 284       endif
 285 c
 286 c 2.3. ==> Les aretes si besoin
 287 c
 288 #ifdef _DEBUG_HOMARD_
 289       write (ulsort,90002) '2.3. aretes ; codret', codret
 290 #endif
 291 c
 292       if ( codret.eq.0 ) then
 293 c
 294       if ( numcas.eq.2 .or. numcas.eq.3 .or. numcas.eq.7 ) then
 295 c
 296 #ifdef _DEBUG_HOMARD_
 297         write (ulsort,texte(langue,3)) 'UTAD02_aret', nompro
 298 #endif
 299         iaux = 10
 300         call utad02 (   iaux, nharet,
 301      >                phetar, psomar,   jaux, pmerar,
 302      >                    jaux,   jaux,   jaux,
 303      >                    jaux,   jaux,   jaux,
 304      >                    jaux,   jaux,   jaux,
 305      >                ulsort, langue, codret )
 306 c
 307       endif
 308 c
 309       endif
 310 c
 311 c 2.4. ==> Les triangles si besoin
 312 c
 313 #ifdef _DEBUG_HOMARD_
 314       write (ulsort,90002) '2.4. triangles ; codret', codret
 315 #endif
 316 c
 317       if ( codret.eq.0 ) then
 318 c
 319       if ( typenh.eq.2 .or.
 320      >     typenh.eq.3 .or. typenh.eq.5 .or. typenh.eq.7 ) then
 321 c
 322 #ifdef _DEBUG_HOMARD_
 323         write (ulsort,texte(langue,3)) 'UTAD02_tria', nompro
 324 #endif
 325         iaux = 110
 326         call utad02 (   iaux, nhtria,
 327      >                phettr, paretr,   jaux, ppertr,
 328      >                  jaux,   jaux,   jaux,
 329      >                pnivtr,   jaux,   jaux,
 330      >                  jaux,   jaux,   jaux,
 331      >                ulsort, langue, codret )
 332 c
 333       endif
 334 c
 335       endif
 336 c
 337 c 2.5. ==> Les quadrangles si besoin
 338 c
 339 #ifdef _DEBUG_HOMARD_
 340       write (ulsort,90002) '2.5. quadrangles ; codret', codret
 341 #endif
 342 c
 343       if ( codret.eq.0 ) then
 344 c
 345       if ( typenh.eq.4 .or.
 346      >     typenh.eq.5 .or. typenh.eq.6 .or. typenh.eq.7 .or.
 347      >     ( typenh.eq.3 .and. ( nbheco.gt.0 .or. nbpeco.gt.0 ) ) ) then
 348 c
 349 #ifdef _DEBUG_HOMARD_
 350         write (ulsort,texte(langue,3)) 'UTAD02_quad', nompro
 351 #endif
 352         iaux = 110
 353         call utad02 (   iaux, nhquad,
 354      >                phetqu, parequ,   jaux, pperqu,
 355      >                  jaux,   jaux,   jaux,
 356      >                pnivqu,   jaux,   jaux,
 357      >                  jaux,   jaux,   jaux,
 358      >                ulsort, langue, codret )
 359 c
 360       endif
 361 c
 362       endif
 363 c
 364 c 2.6. ==> Les hexaedres si besoin
 365 c
 366 #ifdef _DEBUG_HOMARD_
 367       write (ulsort,90002) '2.6. hexaedres ; codret', codret
 368 #endif
 369 c
 370       if ( codret.eq.0 ) then
 371 c
 372       if ( nbheto.gt.0 ) then
 373 c
 374         if ( typenh.eq.3 .or. typenh.eq.5 ) then
 375 c
 376 #ifdef _DEBUG_HOMARD_
 377         write (ulsort,texte(langue,3)) 'UTAD02_hexa', nompro
 378 #endif
 379           iaux = 2
 380           call utad02 (   iaux, nhhexa,
 381      >                  phethe, pquahe,   jaux,   jaux,
 382      >                    jaux,   jaux,   jaux,
 383      >                    jaux,   jaux,   jaux,
 384      >                    jaux,   jaux,   jaux,
 385      >                  ulsort, langue, codret )
 386 c
 387         endif
 388 c
 389       endif
 390 c
 391       endif
 392 c
 393 c 2.7. ==> Les pentaedres si besoin
 394 c
 395 #ifdef _DEBUG_HOMARD_
 396       write (ulsort,90002) '2.7. pentaedres ; codret', codret
 397 #endif
 398 c
 399       if ( codret.eq.0 ) then
 400 c
 401       if ( nbpeto.gt.0 ) then
 402 c
 403         if ( typenh.eq.3 .or. typenh.eq.5 ) then
 404 c
 405 #ifdef _DEBUG_HOMARD_
 406         write (ulsort,texte(langue,3)) 'UTAD02_pent', nompro
 407 #endif
 408           iaux = 2
 409           call utad02 (   iaux, nhpent,
 410      >                  phetpe, pfacpe,   jaux,   jaux,
 411      >                    jaux,   jaux,   jaux,
 412      >                    jaux,   jaux,   jaux,
 413      >                    jaux,   jaux,   jaux,
 414      >                  ulsort, langue, codret )
 415 c
 416         endif
 417 c
 418       endif
 419 c
 420       endif
 421 c
 422 c====
 423 c 3. Creation de la fonction
 424 c====
 425 #ifdef _DEBUG_HOMARD_
 426       write (ulsort,90002) '3. Creation fonction ; codret', codret
 427 #endif
 428 c
 429       if ( codret.eq.0 ) then
 430 c
 431       if ( numcas.le.3 ) then
 432         typcha = edfl64
 433       else
 434         typcha = edint
 435       endif
 436       ngauss = ednopg
 437       nbvapr = -1
 438       nbtyas = 0
 439       carsup = 0
 440       typint = 0
 441 #ifdef _DEBUG_HOMARD_
 442       write (ulsort,texte(langue,3)) 'UTALFO', nompro
 443 #endif
 444       call utalfo ( nofonc, typcha,
 445      >              typgeo, ngauss, nbench, nbvapr, nbtyas,
 446      >              carsup, nbcomp, typint,
 447      >              advale, advalr, adobch, adprpg, adtyas,
 448      >              ulsort, langue, codret )
 449 c
 450       endif
 451 c
 452       if ( codret.eq.0 ) then
 453 c
 454       smem(adobch)   = obcham
 455 c
 456       smem(adprpg)   = blan08
 457       smem(adprpg+1) = blan08
 458       smem(adprpg+2) = blan08
 459 c
 460       caraen( 1,nutvch) = typgeo
 461       caraen( 2,nutvch) = ednodt
 462       caraen( 3,nutvch) = ednoit
 463       caraen( 4,nutvch) = ngauss
 464       caraen( 5,nutvch) = nbench
 465       caraen( 6,nutvch) = nbvapr
 466       caraen( 7,nutvch) = 1
 467       caraen( 8,nutvch) = 0
 468       caraen( 9,nutvch) = 1
 469       caraen(10,nutvch) = 0
 470       caraen(11,nutvch) = 0
 471       caraen(12,nutvch) = 0
 472 c
 473       carare(nutvch) = edundt
 474 c
 475       caraca(1,nutvch) = nofonc
 476       caraca(2,nutvch) = blan08
 477       caraca(3,nutvch) = blan08
 478 c
 479       endif
 480 c
 481 #ifdef _DEBUG_HOMARD_
 482       if ( codret.eq.0 ) then
 483       write (ulsort,90015) 'OBJET fonction'
 484       call gmprsx ( nompro, nofonc )
 485       call gmprsx ( nompro, nofonc//'.InfoCham' )
 486 cgn      call gmprsx ( nompro, nofonc//'.InfoPrPG' )
 487       endif
 488 #endif
 489 c
 490 c====
 491 c 4. Creation du paquet de fonctions
 492 c====
 493 #ifdef _DEBUG_HOMARD_
 494       write (ulsort,90002) '4. Creation paquet ; codret', codret
 495 #endif
 496 c
 497       if ( codret.eq.0 ) then
 498 c
 499       iaux = 1
 500 #ifdef _DEBUG_HOMARD_
 501       write (ulsort,texte(langue,3)) 'UTALPF', nompro
 502 #endif
 503       call utalpf ( nopafo,
 504      >              iaux, typgeo, ngauss, carsup, typint,
 505      >              adobfo, adtyge,
 506      >              ulsort, langue, codret )
 507 c
 508       endif
 509 c
 510       if ( codret.eq.0 ) then
 511 c
 512       smem(adobfo)   = nofonc
 513       smem(adobfo+1) = blan08
 514 c
 515       infopf(nupafo) = nopafo
 516 c
 517       endif
 518 c
 519 #ifdef _DEBUG_HOMARD_
 520       if ( codret.eq.0 ) then
 521       write (ulsort,90015) 'OBJET paquet de fonctions'
 522       call gmprsx ( nompro, nopafo )
 523       call gmprsx ( nompro, nopafo//'.Fonction' )
 524       endif
 525 #endif
 526 c
 527 c====
 528 c 5. Les valeurs
 529 c====
 530 #ifdef _DEBUG_HOMARD_
 531       write (ulsort,90002) '5. valeurs ; codret', codret
 532 #endif
 533 c
 534 c 5.1. ==> Tableaux temporaires
 535 c
 536       if ( codret.eq.0 ) then
 537 c
 538       call gmalot ( ntrav1, 'entier  ', rseutc, adprof, codre1 )
 539       iaux = nbcomp*rseutc
 540       if ( numcas.le.3 ) then
 541         call gmalot ( ntrav2, 'reel    ', iaux, advatt, codre2 )
 542       else
 543         call gmalot ( ntrav2, 'entier  ', iaux, advatt, codre2 )
 544       endif
 545 c
 546       codre0 = min ( codre1, codre2 )
 547       codret = max ( abs(codre0), codret,
 548      >               codre1, codre2 )
 549 c
 550       endif
 551 c
 552 c 5.2. ==> Tableau de travail
 553 c
 554       if ( codret.eq.0 ) then
 555 c
 556 #ifdef _DEBUG_HOMARD_
 557       write (ulsort,texte(langue,3)) 'UTRE03', nompro
 558 #endif
 559       iaux = 7
 560       call utre03 ( typenh, iaux, norenu,
 561      >              jaux, jaux, jaux, adencn,
 562      >              ulsort, langue, codret)
 563 c
 564       endif
 565 c
 566 c 5.3. ==> Calcul
 567 c
 568       if ( codret.eq.0 ) then
 569 c
 570 #ifdef _DEBUG_HOMARD_
 571       write (ulsort,texte(langue,3)) 'INFC03', nompro
 572 #endif
 573       call infc03 ( numcas, typenh, nbcomp, nbenti, nbentf, nbenta,
 574      >              imem(adcode), imem(adinsu), imem(adcoar),
 575      >              imem(admere), imem(adins2), imem(adencn),
 576      >              rmem(pcoono), imem(psomar), imem(pmerar),
 577      >              imem(paretr), imem(ppertr), imem(pnivtr),
 578      >              imem(parequ), imem(pperqu), imem(pnivqu),
 579      >              imem(pquahe), imem(pfacpe),
 580      >              npenrc, entrec,
 581      >              rseutc, imem(adprof), imem(advatt), rmem(advatt),
 582      >              ulsort, langue, codret )
 583 c
 584       endif
 585 c
 586 c 5.4. ==> Mise a jour des numerotations
 587 c
 588       if ( numcas.le.3 ) then
 589 c
 590         if ( codret.eq.0 ) then
 591 c
 592 #ifdef _DEBUG_HOMARD_
 593       write (ulsort,texte(langue,3)) 'UTSRC1', nompro
 594 #endif
 595         call utsrc1 ( nbcomp, rseutc,
 596      >                imem(adprof), rmem(advatt), rmem(advalr) )
 597 c
 598         endif
 599 c
 600       else
 601 c
 602         if ( codret.eq.0 ) then
 603 c
 604 #ifdef _DEBUG_HOMARD_
 605       write (ulsort,texte(langue,3)) 'UTSRC3', nompro
 606 #endif
 607         call utsrc3 ( nbcomp, rseutc,
 608      >                imem(adprof), imem(advatt), imem(advale) )
 609 c
 610         endif
 611 c
 612       endif
 613 c
 614 c 5.5. ==> Menage
 615 c
 616       if ( codret.eq.0 ) then
 617 c
 618       call gmlboj ( ntrav1, codre1 )
 619       call gmlboj ( ntrav2, codre2 )
 620 c
 621       codre0 = min ( codre1, codre2 )
 622       codret = max ( abs(codre0), codret,
 623      >               codre1, codre2 )
 624 c
 625       endif
 626 c
 627 #ifdef _DEBUG_HOMARD_
 628       if ( codret.eq.0 ) then
 629       write (ulsort,90015) 'OBJET fonction'
 630       call gmprsx ( nompro, nofonc//'.ValeursE' )
 631       call gmprsx ( nompro, nofonc//'.ValeursR' )
 632       endif
 633 #endif
 634 c
 635 c====
 636 c 6. la fin
 637 c====
 638 c
 639       if ( codret.ne.0 ) then
 640 c
 641 #include "envex2.h"
 642 c
 643       write (ulsort,texte(langue,1)) 'Sortie', nompro
 644       write (ulsort,texte(langue,2)) codret
 645 c
 646       endif
 647 c
 648 #ifdef _DEBUG_HOMARD_
 649       write (ulsort,texte(langue,1)) 'Sortie', nompro
 650       call dmflsh (iaux)
 651 #endif
 652 c
 653       end