src/tool/Decision/decfsu.F

   1       subroutine decfsu ( nomail, nohind,
   2      >                    lgopti, taopti,
   3      >                    lgetco, taetco,
   4      >                    ulsort, langue, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c traitement des DEcisions - mise en ConFormite - SUppression
  26 c                --                  -  -         --
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  32 c . nohind . e   .  ch8   . nom de l'objet contenant l'indicateur      .
  33 c . lgopti . e   .   1    . longueur du tableau des options            .
  34 c . taopti . e   . lgopti . tableau des options                        .
  35 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  36 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  37 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  38 c . langue . e   .    1   . langue des messages                        .
  39 c .        .     .        . 1 : francais, 2 : anglais                  .
  40 c . codret . es  .    1   . code de retour des modules                 .
  41 c .        .     .        . 0 : pas de probleme                        .
  42 c .        .     .        . 5 : mauvais type de code de calcul associe .
  43 c ______________________________________________________________________
  44 c
  45 c====
  46 c 0. declarations et dimensionnement
  47 c====
  48 c
  49 c 0.1. ==> generalites
  50 c
  51       implicit none
  52       save
  53 c
  54       character*6 nompro
  55       parameter ( nompro = 'DECFSU' )
  56 c
  57 #include "nblang.h"
  58 c
  59 c 0.2. ==> communs
  60 c
  61 #include "envex1.h"
  62 c
  63 #include "gmenti.h"
  64 #include "gmreel.h"
  65 c
  66 #include "envca1.h"
  67 #include "nancnb.h"
  68 #include "nombar.h"
  69 #include "nombtr.h"
  70 #include "nombqu.h"
  71 #include "nombno.h"
  72 #include "nombte.h"
  73 #include "nombpy.h"
  74 #include "nombhe.h"
  75 #include "nombpe.h"
  76 c
  77 c 0.3. ==> arguments
  78 c
  79       character*8 nomail, nohind
  80 c
  81       integer lgopti
  82       integer taopti(lgopti)
  83 c
  84       integer lgetco
  85       integer taetco(lgetco)
  86 c
  87       integer ulsort, langue, codret
  88 c
  89 c 0.4. ==> variables locales
  90 c
  91       integer codava
  92       integer nrosec
  93       integer nretap, nrsset
  94       integer iaux, jaux, kaux
  95 c
  96       integer nbtran, nbquan
  97       integer nbtean
  98       integer nbhean
  99       integer nbpyan
 100       integer nbpean
 101 c
 102       integer pcoono, phetno, pareno
 103       integer adhono
 104       integer pposif, pfacar
 105       integer phetar, psomar, pfilar, pmerar, pancar, pnp2ar
 106       integer adhoar
 107       integer phettr, paretr, pfiltr, ppertr, panctr, pnivtr
 108       integer adpetr, adnmtr
 109       integer adhotr
 110       integer phetqu, parequ, pfilqu, pperqu, pancqu, pnivqu
 111       integer adhequ, adnmqu
 112       integer adhoqu
 113       integer phette, ptrite, pcotrt, parete, pfilte, pperte, pancte
 114       integer phethe, pquahe, pcoquh, parehe, pfilhe, pperhe, panche
 115       integer adnmhe
 116       integer adhes2
 117       integer phetpy, pfacpy, pcofay, parepy, pfilpy, pperpy, pancpy
 118       integer phetpe, pfacpe, pcofap, parepe, pfilpe, pperpe, pancpe
 119       integer adpes2
 120       integer pfamno, pcfano
 121       integer pfamar
 122       integer pfamtr
 123       integer pfamqu
 124       integer pfamte
 125       integer pfampy
 126       integer pfamhe
 127       integer pfampe
 128       integer voarno, vofaar, vovoar, vovofa
 129       integer adnoin, adnorn, adnosu
 130       integer adarin, adarrn, adarsu
 131       integer adtrin, adtrrn, adtrsu
 132       integer adquin, adqurn, adqusu
 133       integer adtein, adtern, adtesu
 134       integer adhein, adhern, adhesu
 135       integer adpyin, adpyrn, adpysu
 136       integer adpein, adpern, adpesu
 137       integer nbvnoe, nbvare
 138       integer nbvtri, nbvqua
 139       integer nbvtet, nbvhex, nbvpyr, nbvpen
 140       integer typind, ncmpin
 141       integer pdisno, pancno, pnouno
 142 c
 143       logical afaire
 144 c
 145       integer codre0
 146       integer codre1, codre2, codre3
 147 c
 148       character*6 saux
 149       character*8 saux08
 150       character*8 norenu
 151       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 152       character*8 nhtetr, nhhexa, nhpyra, nhpent
 153       character*8 nhelig
 154       character*8 nhvois, nhsupe, nhsups
 155       character*8 ndisno, nnouno
 156 c
 157       integer nbmess
 158       parameter ( nbmess = 10 )
 159       character*80 texte(nblang,nbmess)
 160 c
 161 c 0.5. ==> initialisations
 162 c ______________________________________________________________________
 163 c
 164 c====
 165 c 1. messages
 166 c====
 167 #include "impr02.h"
 168 c
 169 #include "impr01.h"
 170 c
 171 #ifdef _DEBUG_HOMARD_
 172       write (ulsort,texte(langue,1)) 'Entree', nompro
 173       call dmflsh (iaux)
 174 #endif
 175 c
 176 #include "impr03.h"
 177 c
 178       codava = codret
 179 c
 180 c=======================================================================
 181       if ( codava.eq.0 ) then
 182 c=======================================================================
 183 c
 184 c 1.1. ==> le debut des mesures de temps
 185 c
 186       nrosec = taetco(4)
 187       call gtdems (nrosec)
 188 c
 189 c 1.3. ==> les messages
 190 c
 191       texte(1,4) = '(/,a6,'' SUPPRESSION DE LA CONFORMITE'')'
 192       texte(1,5) = '(35(''=''),/)'
 193       texte(1,6) = '(''Modification de taille des tableaux des '',a)'
 194       texte(1,7) = '(''et renumerotation.'')'
 195       texte(1,8) = '(5x,''==> code de retour :'',i8)'
 196 c
 197       texte(2,4) = '(/,a6,'' SUPPRESSION OF CONFORMITY'')'
 198       texte(2,5) = '(32(''=''),/)'
 199       texte(2,6) = '(''Size modification of arrays for '',a)'
 200       texte(2,7) = '(''and renumbering.'')'
 201       texte(2,8) = '(5x,''==> error code :'',i8)'
 202 c
 203 c 1.4. ==> le numero de sous-etape
 204 c
 205       nretap = taetco(1)
 206       nrsset = taetco(2) + 1
 207       taetco(2) = nrsset
 208 c
 209       call utcvne ( nretap, nrsset, saux, iaux, codret )
 210 c
 211 c 1.5. ==> le titre
 212 c
 213       write (ulsort,texte(langue,4)) saux
 214       write (ulsort,texte(langue,5))
 215 c
 216 c====
 217 c 2. recuperation des pointeurs, initialisations
 218 c====
 219 c
 220 c 2.1. ==> structure generale
 221 c
 222       if ( codret.eq.0 ) then
 223 c
 224 #ifdef _DEBUG_HOMARD_
 225       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 226 #endif
 227       call utnomh ( nomail,
 228      >                sdim,   mdim,
 229      >               degre, maconf, homolo, hierar,
 230      >              rafdef, nbmane, typcca, typsfr, maextr,
 231      >              mailet,
 232      >              norenu,
 233      >              nhnoeu, nhmapo, nharet,
 234      >              nhtria, nhquad,
 235      >              nhtetr, nhhexa, nhpyra, nhpent,
 236      >              nhelig,
 237      >              nhvois, nhsupe, nhsups,
 238      >              ulsort, langue, codret)
 239 c
 240       endif
 241 c
 242 c 2.2. ==> tableaux
 243 c
 244       if ( codret.eq.0 ) then
 245 c
 246       iaux = 210
 247       if ( homolo.ge.1 ) then
 248         iaux = iaux*11
 249       endif
 250 #ifdef _DEBUG_HOMARD_
 251       write (ulsort,texte(langue,3)) 'UTAD01', nompro
 252 #endif
 253       call utad01 ( iaux, nhnoeu,
 254      >              phetno,
 255      >              pfamno, pcfano,   jaux,
 256      >              pcoono, pareno, adhono,  jaux,
 257      >              ulsort, langue, codret )
 258 c
 259       iaux = 2
 260       if ( degre.eq.2 ) then
 261         iaux = iaux*13
 262       endif
 263 #ifdef _DEBUG_HOMARD_
 264       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 265 #endif
 266       call utad02 (   iaux, nharet,
 267      >              phetar, psomar, jaux  , jaux  ,
 268      >                jaux,   jaux,   jaux,
 269      >                jaux, pnp2ar,   jaux,
 270      >                jaux,   jaux,   jaux,
 271      >              ulsort, langue, codret )
 272 c
 273       if ( nbtrto.ne.0 ) then
 274 c
 275         iaux = 30*11
 276 #ifdef _DEBUG_HOMARD_
 277       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 278 #endif
 279         call utad02 (   iaux, nhtria,
 280      >                phettr, paretr, pfiltr, ppertr,
 281      >                  jaux,   jaux,   jaux,
 282      >                pnivtr,   jaux,   jaux,
 283      >                  jaux,   jaux,   jaux,
 284      >                ulsort, langue, codret )
 285 c
 286       endif
 287 c
 288       if ( nbquto.ne.0 ) then
 289 c
 290         iaux = 30*11
 291 #ifdef _DEBUG_HOMARD_
 292       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 293 #endif
 294         call utad02 (   iaux, nhquad,
 295      >                phetqu, parequ, pfilqu, pperqu,
 296      >                  jaux,   jaux,   jaux,
 297      >                pnivqu,   jaux,   jaux,
 298      >                  jaux,   jaux,   jaux,
 299      >                ulsort, langue, codret )
 300 c
 301       endif
 302 c
 303       if ( nbteto.ne.0 ) then
 304 c
 305         iaux = 78
 306         if ( nancta.gt.0 ) then
 307           iaux = iaux*31
 308         endif
 309 #ifdef _DEBUG_HOMARD_
 310       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 311 #endif
 312         call utad02 (   iaux, nhtetr,
 313      >                phette, ptrite, pfilte, jaux,
 314      >                  jaux,   jaux,   jaux,
 315      >                  jaux, pcotrt,   jaux,
 316      >                  jaux,   jaux, parete,
 317      >                ulsort, langue, codret )
 318 c
 319       endif
 320 c
 321       if ( nbheto.ne.0 ) then
 322 c
 323         iaux = 6
 324         if ( nbheco.ne.0 ) then
 325            iaux = iaux*17
 326         endif
 327         if ( nancha.gt.0 ) then
 328           iaux = iaux*31
 329         endif
 330 #ifdef _DEBUG_HOMARD_
 331       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 332 #endif
 333         call utad02 (   iaux, nhhexa,
 334      >                phethe, pquahe, pfilhe, jaux,
 335      >                  jaux,   jaux,   jaux,
 336      >                  jaux,   jaux, adhes2,
 337      >                  jaux,   jaux, parehe,
 338      >                ulsort, langue, codret )
 339 c
 340       endif
 341 c
 342       if ( nbpeto.ne.0 ) then
 343 c
 344         iaux = 6
 345         if ( nbpeco.ne.0 ) then
 346            iaux = iaux*17
 347         endif
 348         if ( nancpa.gt.0 ) then
 349           iaux = iaux*31
 350         endif
 351 #ifdef _DEBUG_HOMARD_
 352       write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 353 #endif
 354         call utad02 (   iaux, nhpent,
 355      >                phetpe, pfacpe, pfilpe, jaux,
 356      >                  jaux,   jaux,   jaux,
 357      >                  jaux,   jaux, adpes2,
 358      >                  jaux,   jaux, parepe,
 359      >                ulsort, langue, codret )
 360 c
 361       endif
 362 c
 363       if ( nbpyto.ne.0 ) then
 364 c
 365         iaux = 6
 366         if ( nancya.gt.0 ) then
 367           iaux = iaux*31
 368         endif
 369 #ifdef _DEBUG_HOMARD_
 370       write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
 371 #endif
 372         call utad02 (   iaux, nhpyra,
 373      >                phetpy, pfacpy, jaux, jaux,
 374      >                  jaux,   jaux,   jaux,
 375      >                  jaux,   jaux, pcofay,
 376      >                  jaux,   jaux, parepy,
 377      >                ulsort, langue, codret )
 378 c
 379       endif
 380 c
 381       endif
 382 c
 383 c 2.3. ==> si le raffinement ou le deraffinement sont pilotes par un
 384 c          indicateur, recuperation de l'indicateur
 385 c
 386       nbvtri = 0
 387       nbvqua = 0
 388       nbvtet = 0
 389       nbvhex = 0
 390       nbvpyr = 0
 391       nbvpen = 0
 392 c
 393       if ( ( taopti(31).gt.0 .or. taopti(32).gt.0 ) .and.
 394      >     taopti(37).eq.0 ) then
 395 c
 396 c 2.3.1. ==> la situation actuelle
 397 c
 398         if ( codret.eq.0 ) then
 399 c
 400 #ifdef _DEBUG_HOMARD_
 401       write (ulsort,texte(langue,3)) 'DEINI0', nompro
 402 #endif
 403         call deini0 ( nohind, typind, ncmpin,
 404      >                nbvnoe, nbvare,
 405      >                nbvtri, nbvqua,
 406      >                nbvtet, nbvhex, nbvpyr, nbvpen,
 407      >                adnoin, adnorn, adnosu,
 408      >                adarin, adarrn, adarsu,
 409      >                adtrin, adtrrn, adtrsu,
 410      >                adquin, adqurn, adqusu,
 411      >                adtein, adtern, adtesu,
 412      >                adhein, adhern, adhesu,
 413      >                adpyin, adpyrn, adpysu,
 414      >                adpein, adpern, adpesu,
 415      >                ulsort, langue, codret )
 416 c
 417         endif
 418 c
 419 c 2.3.2. ==> complement eventuels
 420 c
 421         if ( codret.eq.0 ) then
 422 c
 423 #ifdef _DEBUG_HOMARD_
 424       write (ulsort,texte(langue,3)) 'DEINI2', nompro
 425 #endif
 426         call deini2 ( nohind, typind, ncmpin,
 427      >                nbvtri, nbvqua,
 428      >                nbvtet, nbvhex, nbvpyr,
 429      >                adquin, adqurn, adqusu,
 430      >                adhein, adhern, adhesu,
 431      >                ulsort, langue, codret )
 432 c
 433         endif
 434 c
 435       endif
 436 c
 437 #ifdef _DEBUG_HOMARD_
 438       write (ulsort,90002) 'nbvnoe', nbvnoe
 439       write (ulsort,90002) 'nbvare', nbvare
 440       write (ulsort,90002) 'nbvtri', nbvtri
 441       write (ulsort,90002) 'nbvqua', nbvqua
 442       write (ulsort,90002) 'nbvtet', nbvtet
 443       write (ulsort,90002) 'nbvhex', nbvhex
 444       write (ulsort,90002) 'nbvpyr', nbvpyr
 445       write (ulsort,90002) 'nbvpen', nbvpen
 446 #endif
 447 c
 448 c====
 449 c 3. Transfert de l'indicateur s'il est defini par maille
 450 c    Remarque : on suppose que s'il est defini sur les noeuds, il ne
 451 c               peut pas avoir de valeurs sur les mailles
 452 c====
 453 #ifdef _DEBUG_HOMARD_
 454       write (ulsort,90002) '3. Transfert ; codret', codret
 455 #endif
 456 c
 457       if ( nbvnoe.eq.0 ) then
 458 c
 459 c 3.1. ==> Indicateur pris en valeur relative
 460 c
 461         if ( taopti(8).eq.2 ) then
 462 c
 463           if ( codret.eq.0 ) then
 464 c
 465 #ifdef _DEBUG_HOMARD_
 466         write (ulsort,texte(langue,3)) 'DECFS0', nompro
 467 #endif
 468           call decfs0 ( imem(phettr), imem(pfiltr),
 469      >                  imem(phetqu), imem(pfilqu),
 470      >                  imem(phette), imem(pfilte),
 471      >                  imem(phethe), imem(pfilhe), imem(adhes2),
 472      >                  imem(phetpe), imem(pfilpe), imem(adpes2),
 473      >                  nbvtri, nbvqua,
 474      >                  nbvtet, nbvpyr,
 475      >                  rmem(adtrrn), imem(adtrsu),
 476      >                  rmem(adqurn), imem(adqusu),
 477      >                  rmem(adtern), imem(adtesu),
 478      >                  rmem(adhern), imem(adhesu),
 479      >                  rmem(adpyrn), imem(adpysu),
 480      >                  rmem(adpern), imem(adpesu),
 481      >                  ulsort, langue, codret )
 482 c
 483           endif
 484 c
 485 c 3.2. ==> Indicateur pris en valeur absolue : norme L2 ou infinie
 486 c
 487         else
 488 c
 489           if ( codret.eq.0 ) then
 490 c
 491 #ifdef _DEBUG_HOMARD_
 492       write (ulsort,texte(langue,3)) 'DECFS1', nompro
 493 #endif
 494           call decfs1 ( imem(phettr), imem(pfiltr),
 495      >                  imem(phetqu), imem(pfilqu),
 496      >                  imem(phette), imem(pfilte),
 497      >                  imem(phethe), imem(pfilhe), imem(adhes2),
 498      >                  imem(phetpe), imem(pfilpe), imem(adpes2),
 499      >                  nbvtri, nbvqua,
 500      >                  nbvtet, nbvpyr,
 501      >                  rmem(adtrrn), imem(adtrsu),
 502      >                  rmem(adqurn), imem(adqusu),
 503      >                  rmem(adtern), imem(adtesu),
 504      >                  rmem(adhern), imem(adhesu),
 505      >                  rmem(adpyrn), imem(adpysu),
 506      >                  rmem(adpern), imem(adpesu),
 507      >                  ulsort, langue, codret )
 508 c
 509           endif
 510 c
 511         endif
 512 c
 513       endif
 514 c
 515 c====
 516 c 4. mise a jour de certaines donnees concernant le maillage
 517 c====
 518 #ifdef _DEBUG_HOMARD_
 519       write (ulsort,90002) '4. mise a jour ; codret', codret
 520       write (ulsort,90002) 'nbnoto', nbnoto
 521       write (ulsort,90002) 'nbarto', nbarto
 522       write (ulsort,90002) 'nbnoto, nbnop1, nbnop2',
 523      >                      nbnoto, nbnop1, nbnop2
 524 #endif
 525 c
 526       if ( codret.eq.0 ) then
 527 c
 528 #ifdef _DEBUG_HOMARD_
 529       write (ulsort,texte(langue,3)) 'DESMAJ', nompro
 530 #endif
 531       call desmaj ( nhnoeu, nharet, nhtria, nhquad,
 532      >              nhtetr, nhhexa, nhpyra, nhpent,
 533      >              afaire,
 534      >              ulsort, langue, codret )
 535 c
 536 #ifdef _DEBUG_HOMARD_
 537       write (ulsort,90015) 'nancno', nancno, ' ==> nbnoto', nbnoto
 538       write (ulsort,90015) 'nancar', nancar, ' ==> nbarto', nbarto
 539       write (ulsort,90015) 'nanctr', nanctr, ' ==> nbtrto', nbtrto
 540       write (ulsort,90015) 'nancqu', nancqu, ' ==> nbquto', nbquto
 541       write (ulsort,99001) 'afaire', afaire
 542 #endif
 543       endif
 544 c
 545 c====
 546 c 5. Gestion des tableaux dont la taille a ete modifiee
 547 c    Attention : il faut commencer par les noeuds car on a besoin
 548 c    de la structure complete du maillage pour les renumerotations
 549 c====
 550 #ifdef _DEBUG_HOMARD_
 551       write (ulsort,90002) '5. tableaux ; codret', codret
 552       write (ulsort,90002) 'nancno', nancno
 553       write (ulsort,90002) 'nbnoto', nbnoto
 554 #endif
 555 c
 556 c 5.1. ==> Les noeuds
 557 #ifdef _DEBUG_HOMARD_
 558       write (ulsort,90002) '5.1 degre 2 ; codret', codret
 559 #endif
 560 c
 561 c 5.1.1. ==> Renumerotation eventuelle
 562 c
 563       if ( nancno.ne.nbnoto ) then
 564 c
 565 c 5.1.1.1. ==> Les tableaux
 566 c
 567         if ( afaire ) then
 568 c
 569           if ( codret.eq.0 ) then
 570 c
 571           call gmalot ( ndisno, 'entier  ', nancno, pdisno, codre1 )
 572           call gmaloj ( nhnoeu//'.Deraffin', ' ',
 573      >                  nancno, pancno, codre2 )
 574           iaux = nancno + 1
 575           call gmalot ( nnouno, 'entier  ', iaux, pnouno, codre3 )
 576 c
 577           codre0 = min ( codre1, codre2, codre3 )
 578           codret = max ( abs(codre0), codret,
 579      >                 codre1, codre2, codre3 )
 580 c
 581           endif
 582 c
 583           iaux = 0
 584           if ( ( taopti(31).gt.0 .or. taopti(32).gt.0 ) .and.
 585      >           taopti(37).eq.0 ) then
 586 c
 587             if ( typind.eq.2 ) then
 588               saux08 = 'ValeursE'
 589             else
 590               saux08 = 'ValeursR'
 591             endif
 592             call gmobal ( nohind//'.Noeud.'//saux08, codre0 )
 593             if ( codre0.eq.2 ) then
 594               call gmadoj ( nohind//'.Noeud.'//saux08,
 595      >                      jaux, iaux, codre0 )
 596               codret = max (codret, abs(codre0) )
 597               iaux = typind
 598             endif
 599 c
 600           endif
 601 c
 602 c 5.1.1.2. ==> La renumerotation des tableaux lies aux noeuds
 603 #ifdef _DEBUG_HOMARD_
 604       write (ulsort,90002) '5.1.1.2 Renumerotation ; codret', codret
 605 #endif
 606 c
 607           if ( codret.eq.0 ) then
 608 c
 609 #ifdef _DEBUG_HOMARD_
 610       write (ulsort,texte(langue,3)) 'DECFS2', nompro
 611 #endif
 612           call decfs2 ( imem(pdisno), imem(pancno), imem(pnouno),
 613      >                  imem(phetno), imem(pfamno), imem(pareno),
 614      >                  imem(adhono), rmem(pcoono),
 615      >                  imem(pnp2ar), imem(psomar),
 616      >                  imem(paretr),
 617      >                  imem(phetqu), imem(parequ), imem(pfilqu),
 618      >                  imem(ptrite), imem(pcotrt), imem(parete),
 619      >                  imem(phethe), imem(pfilhe), imem(adhes2),
 620      >                  imem(pfacpy), imem(pcofay), imem(parepy),
 621      >                  imem(phetpe), imem(pfilpe), imem(adpes2),
 622      >                  iaux, imem(jaux), rmem(jaux),
 623      >                  ulsort, langue, codret )
 624 c
 625           endif
 626 c
 627 c 5.1.1.3. ==> Le menage
 628 #ifdef _DEBUG_HOMARD_
 629       write (ulsort,90002) '5.1.1.3 Menage ; codret', codret
 630 #endif
 631 c
 632           if ( codret.eq.0 ) then
 633 c
 634           call gmlboj ( ndisno, codre1 )
 635           call gmlboj ( nnouno, codre2 )
 636 c
 637           codre0 = min ( codre1, codre2 )
 638           codret = max ( abs(codre0), codret,
 639      >                   codre1, codre2 )
 640 c
 641           endif
 642 c
 643         endif
 644 c
 645       endif
 646 c
 647 c 5.1.2. ==> Raccourcissement des tableaux
 648 #ifdef _DEBUG_HOMARD_
 649       write (ulsort,90002) '5.1.2 Raccourcissement ; codret', codret
 650       write (ulsort,90002) 'nancno', nancno
 651       write (ulsort,90002) 'nbnoto', nbnoto
 652       write (ulsort,90002) 'nancar', nancar
 653       write (ulsort,90002) 'nbarto', nbarto
 654 #endif
 655 c
 656       if ( codret.eq.0 ) then
 657 c
 658       iaux = 210
 659       if ( homolo.ge.1 ) then
 660         iaux = iaux*11
 661       endif
 662       if ( afaire ) then
 663         iaux = iaux*13
 664       endif
 665       jaux = 1
 666 #ifdef _DEBUG_HOMARD_
 667       write (ulsort,texte(langue,3)) 'UTAD05', nompro
 668 #endif
 669       call utad05 ( iaux, jaux, nhnoeu,
 670      >              nancno, nbnoto, sdim,
 671      >              phetno,
 672      >              pfamno,
 673      >              pcoono, pareno, adhono, pancno,
 674      >              ulsort, langue, codret )
 675 c
 676       call gmecat ( nhnoeu, 1, nbnoto, codre0 )
 677 c
 678       codret = max ( abs(codre0), codret )
 679 c
 680 #ifdef _DEBUG_HOMARD_
 681       write (ulsort,90002) '5.1.2 nohind ; codret', codret
 682 #endif
 683 c
 684       if ( ( taopti(31).gt.0 .or. taopti(32).gt.0 ) .and.
 685      >       taopti(37).eq.0 ) then
 686 c
 687         if ( typind.eq.2 ) then
 688           saux08 = 'ValeursE'
 689         else
 690           saux08 = 'ValeursR'
 691         endif
 692         call gmobal ( nohind//'.Noeud.'//saux08, codre0 )
 693         if ( codre0.eq.2 ) then
 694           call gmmod ( nohind//'.Noeud.'//saux08,
 695      >                 jaux, nancno, nbnoto, ncmpin, ncmpin, codre0 )
 696           codret = max ( abs(codre0), codret )
 697         endif
 698         if ( typind.eq.2 ) then
 699           adnoin = jaux
 700         else
 701           adnorn = jaux
 702         endif
 703 c
 704       endif
 705 c
 706       endif
 707 c
 708 #ifdef _DEBUG_HOMARD_
 709       write (ulsort,texte(langue,6)) 'noeuds'
 710       write (ulsort,texte(langue,8)) codret
 711 #endif
 712 c
 713 c 5.2. ==> Suppression des fils de mise en conformite
 714 #ifdef _DEBUG_HOMARD_
 715       write (ulsort,90002) '5.2 Suppression fils ; codret', codret
 716 #endif
 717 c
 718       if ( codret.eq.0 ) then
 719       call gmobal ( nhhexa//'.InfoSup2', codre0 )
 720       if ( codre0.eq.2 ) then
 721         call gmlboj ( nhhexa//'.InfoSup2', codret )
 722       endif
 723       endif
 724 c
 725       if ( codret.eq.0 ) then
 726       call gmobal ( nhpent//'.InfoSup2', codre0 )
 727       if ( codre0.eq.2 ) then
 728         call gmlboj ( nhpent//'.InfoSup2', codret )
 729       endif
 730       endif
 731 c
 732       if ( codret.eq.0 ) then
 733       call gmobal ( nhtetr//'.InfoSup2', codre0 )
 734       if ( codre0.eq.2 ) then
 735         call gmlboj ( nhtetr//'.InfoSup2', codret )
 736       endif
 737       endif
 738 c
 739       if ( codret.eq.0 ) then
 740       call gmobal ( nhpyra//'.InfoSup2', codre0 )
 741       if ( codre0.eq.2 ) then
 742         call gmlboj ( nhpyra//'.InfoSup2', codret )
 743       endif
 744       endif
 745 c
 746       if ( codret.eq.0 ) then
 747 c
 748 #ifdef _DEBUG_HOMARD_
 749       write (ulsort,texte(langue,3)) 'DECFS3', nompro
 750 #endif
 751       call decfs3 ( imem(phettr), imem(pfiltr),
 752      >              imem(phetqu), imem(pfilqu),
 753      >              imem(phette), imem(pfilte),
 754      >              imem(phethe), imem(pfilhe),
 755      >              imem(phetpe), imem(pfilpe),
 756      >              ulsort, langue, codret )
 757 c
 758       endif
 759 c
 760 c 5.3. ==> Redimensionnement des tableaux du maillage
 761 c          On detruit les objets de tailles nulles
 762 #ifdef _DEBUG_HOMARD_
 763       write (ulsort,90002) '5.3. Redim maillage ; codret', codret
 764       write (ulsort,90002) 'nbtrto, nanctr', nbtrto, nanctr
 765       write (ulsort,90002) 'nbquto, nancqu', nbquto, nancqu
 766       write (ulsort,90002) 'nbteto, nancte', nbteto, nancte
 767       write (ulsort,90002) 'nbheto, nanche', nbheto, nanche
 768       write (ulsort,90002) 'nbpyto, nancpy', nbpyto, nancpy
 769       write (ulsort,90002) 'nbpeto, nancpe', nbpeto, nancpe
 770 #endif
 771 c
 772       if ( codret.eq.0 ) then
 773 c
 774       iaux = 0
 775       jaux = 0
 776       if ( nbtrto.ne.0 .or. nanctr.ne.0 ) then
 777         nbtran = nanctr
 778       else
 779         nbtran = -1
 780       endif
 781       if ( nbquto.ne.0 .or. nancqu.ne.0 ) then
 782         nbquan = nancqu
 783       else
 784         nbquan = -1
 785       endif
 786       if ( nbteto.ne.0 .or. nancte.ne.0 ) then
 787         nbtean = nancte
 788       else
 789         nbtean = -1
 790       endif
 791       if ( nbheto.ne.0 .or. nanche.ne.0 ) then
 792         nbhean = nanche
 793       else
 794         nbhean = -1
 795       endif
 796       if ( nbpyto.ne.0 .or. nancpy.ne.0 ) then
 797         nbpyan = nancpy
 798       else
 799         nbpyan = -1
 800       endif
 801       if ( nbpeto.ne.0 .or. nancpe.ne.0 ) then
 802         nbpean = nancpe
 803       else
 804         nbpean = -1
 805       endif
 806 #ifdef _DEBUG_HOMARD_
 807       write (ulsort,90002) 'nbtran', nbtran
 808       write (ulsort,90002) 'nbquan', nbquan
 809       write (ulsort,90002) 'nbtean', nbtean
 810       write (ulsort,90002) 'nbhean', nbhean
 811       write (ulsort,90002) 'nbpyan', nbpyan
 812       write (ulsort,90002) 'nbpean', nbpean
 813 #endif
 814 #ifdef _DEBUG_HOMARD_
 815       write (ulsort,texte(langue,3)) 'UTAD98', nompro
 816 #endif
 817       call utad98 ( nomail,   iaux,   jaux,
 818      >              nancar, nbarto,
 819      >              nbtran, nbtrto,
 820      >              nbquan, nbquto,
 821      >              nbtean, nbteto, nancta, kaux,
 822      >              nbhean, nbheto, nancha, kaux,
 823      >              nbpyan, nbpyto, nancya, kaux,
 824      >              nbpean, nbpeto, nancpa, kaux,
 825      >              phetar, psomar, pfilar, pmerar, pancar,
 826      >              pnp2ar, adhoar,
 827      >              phettr, paretr, pfiltr, ppertr, panctr,
 828      >              pnivtr, adpetr, adnmtr, adhotr,
 829      >              phetqu, parequ, pfilqu, pperqu, pancqu,
 830      >              pnivqu, adhequ, adnmqu, adhoqu,
 831      >              phette, ptrite, pcotrt, parete,
 832      >              pfilte, pperte, pancte,
 833      >              phethe, pquahe, pcoquh, parehe,
 834      >              pfilhe, pperhe, panche, adnmhe,
 835      >              phetpy, pfacpy, pcofay, parepy,
 836      >              pfilpy, pperpy, pancpy,
 837      >              phetpe, pfacpe, pcofap, parepe,
 838      >              pfilpe, pperpe, pancpe,
 839      >              pfamar, pfamtr, pfamqu,
 840      >              pfamte, pfamhe, pfampy, pfampe,
 841      >              ulsort, langue, codret )
 842 c
 843       endif
 844 c
 845 c 5.4. ==> si le raffinement ou le deraffinement sont pilotes par un
 846 c          indicateur, suppression des structures inutiles
 847 #ifdef _DEBUG_HOMARD_
 848       write (ulsort,90002) '5.4. suppression ; codret', codret
 849 #endif
 850 c
 851       if ( ( taopti(31).gt.0 .or. taopti(32).gt.0 ) .and.
 852      >     taopti(37).eq.0 ) then
 853 c
 854         if ( codret.eq.0 ) then
 855 c
 856 #ifdef _DEBUG_HOMARD_
 857       write (ulsort,texte(langue,3)) 'DEINI3', nompro
 858 #endif
 859         call deini3 ( nohind,
 860      >                nbvtri, nbvqua,
 861      >                nbvtet, nbvhex, nbvpyr, nbvpen,
 862      >                ulsort, langue, codret )
 863 c
 864         endif
 865 c
 866       endif
 867 c
 868 c====
 869 c 6. determination des voisinages
 870 c====
 871 #ifdef _DEBUG_HOMARD_
 872       write (ulsort,90002) '6. voisinage ; codret', codret
 873 #endif
 874 c
 875       if ( codret.eq.0 ) then
 876 c
 877       voarno = 0
 878       vofaar = 1
 879       vovoar = 0
 880       vovofa = 1
 881 c
 882 #ifdef _DEBUG_HOMARD_
 883       write (ulsort,texte(langue,3)) 'UTVOIS', nompro
 884 #endif
 885       call utvois ( nomail, nhvois,
 886      >              voarno, vofaar, vovoar, vovofa,
 887      >              iaux  , jaux  ,
 888      >              nbfaar, pposif, pfacar,
 889      >              ulsort, langue, codret )
 890 c
 891 #ifdef _DEBUG_HOMARD_
 892       write (ulsort,90002) 'Apres 6. voisinages : codret', codret
 893 #endif
 894 c
 895       endif
 896 c
 897 c====
 898 c 7. la fin
 899 c====
 900 c
 901 c 7.1. ==> message si erreur
 902 c
 903       if ( codret.ne.0 ) then
 904 c
 905 #include "envex2.h"
 906 c
 907       write (ulsort,texte(langue,1)) 'Sortie', nompro
 908       write (ulsort,texte(langue,2)) codret
 909 c
 910       endif
 911 c
 912 c 7.2. ==> fin des mesures de temps de la section
 913 c
 914       call gtfims (nrosec)
 915 c
 916 #ifdef _DEBUG_HOMARD_
 917       write (ulsort,texte(langue,1)) 'Sortie', nompro
 918       call dmflsh (iaux)
 919 #endif
 920 c
 921 c=======================================================================
 922       endif
 923 c=======================================================================
 924 c
 925       end