src/tool/Creation_Maillage/cmdera.F

   1       subroutine cmdera ( nomail,
   2      >                    indnoe, indnp2, indnim, indare,
   3      >                    indtri, indqua,
   4      >                    indtet, indhex, indpen,
   5      >                    lgopts, taopts, lgetco, taetco,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c    Creation du Maillage - DERAffinement
  28 c    -           -          ----
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  34 c . indnoe .   s .   1    . nombre de noeuds restants apres deraff.    .
  35 c . indnp2 .   s .   1    . nombre de noeuds p2 restants apres deraff. .
  36 c . indnim .   s .   1    . nombre de noeuds internes restants ap deraf.
  37 c . indare .   s .   1    . nombre d'aretes restantes apres deraff.    .
  38 c . indtri .   s .   1    . nombre de triangles restants apres deraff. .
  39 c . indqua .   s .   1    . nombre de quads restants apres deraff.     .
  40 c . indtet .   s .   1    . nombre de tetraedres restants apres deraff..
  41 c . indhex .   s .   1    . nombre de hexaedres restants apres deraff. .
  42 c . indpen .   s .   1    . indice du dernier pentaedre cree           .
  43 c . lgopts . e   .   1    . longueur du tableau des options caracteres .
  44 c . taopts . e   . lgopts . tableau des options caracteres             .
  45 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  46 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  47 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  48 c . langue . e   .   1    . langue des messages                        .
  49 c .        .     .        . 1 : francais, 2 : anglais                  .
  50 c . codret . e/s .   1    . code de retour des modules                 .
  51 c .        .     .        . 0 : pas de probleme                        .
  52 c ______________________________________________________________________
  53 c
  54 c====
  55 c 0. declarations et dimensionnement
  56 c====
  57 c
  58 c 0.1. ==> generalites
  59 c
  60       implicit none
  61       save
  62 c
  63       character*6 nompro
  64       parameter ( nompro = 'CMDERA' )
  65 c
  66 #include "nblang.h"
  67 c
  68 c 0.2. ==> communs
  69 c
  70 #include "envex1.h"
  71 c
  72 #include "gmenti.h"
  73 #include "gmreel.h"
  74 c
  75 #include "envca1.h"
  76 #include "nombno.h"
  77 #include "nombar.h"
  78 #include "nombtr.h"
  79 #include "nombqu.h"
  80 #include "nombte.h"
  81 #include "nombhe.h"
  82 #include "nombpy.h"
  83 #include "nombpe.h"
  84 #include "nouvnb.h"
  85 c
  86 c 0.3. ==> arguments
  87 c
  88       character*8 nomail
  89 c
  90       integer indnoe, indnp2, indnim, indare, indtri, indqua
  91       integer indtet, indhex, indpen
  92 c
  93       integer lgopts
  94       character*8 taopts(lgopts)
  95 c
  96       integer lgetco
  97       integer taetco(lgetco)
  98 c
  99       integer ulsort, langue, codret
 100 c
 101 c 0.4. ==> variables locales
 102 c
 103       integer codava, nretap, nrsset
 104       integer iaux, jaux, ideb, ifin
 105       integer tbiaux(1)
 106 c
 107       integer codre1, codre2, codre3, codre4, codre5
 108       integer codre6, codre7, codre8
 109       integer codre0
 110       integer pdecar, pdecfa
 111       integer phetno, pcoono, pareno
 112       integer phetar, psomar, pfilar, pmerar, pnp2ar
 113       integer phettr, paretr, pfiltr, ppertr, pnivtr, adnmtr
 114       integer phetqu, parequ, pfilqu, pperqu, pnivqu, adnmqu
 115       integer phette, ptrite, pcotrt, pfilte, pperte
 116       integer phethe, pquahe, pcoquh, pfilhe, pperhe, adnmhe
 117       integer phetpe, pfacpe, pcofap, pfilpe, pperpe
 118       integer pfamno, pcfano
 119       integer pfamar
 120       integer pfamtr
 121       integer pfamqu
 122       integer pfamte
 123       integer pfamhe
 124       integer pfampe
 125       integer pfacar, pposif
 126       integer nbpere, pdispe, pancpe, pnoupe
 127       integer nbhere, pdishe, panche, pnouhe
 128       integer nbtere, pdiste, pancte, pnoute
 129 cgn      integer nbpyre, pdispy, pancpy, pnoupy
 130       integer         pdispy, pancpy, pnoupy
 131       integer nbqure, pdisqu, pancqu, pnouqu
 132       integer nbtrre, pdistr, panctr, pnoutr
 133       integer nbarre, pdisar, pancar, pnouar
 134       integer nbnore, pdisno, pancno, pnouno
 135       integer nbp2re, nbimre
 136       integer adhono, adhoar, adhotr, adhoqu
 137       integer ptrav3, ptrav4
 138       integer nbancn
 139 c
 140       character*6 saux
 141       character*8 norenu
 142       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 143       character*8 nhtetr, nhhexa, nhpyra, nhpent
 144       character*8 nhelig
 145       character*8 nhvois, nhsupe, nhsups
 146       character*8 nnoupy, nnoupe, nnouhe, nnoute
 147       character*8 nnouqu, nnoutr, nnouar, nnouno
 148       character*8 ndispy, ndispe, ndishe, ndiste
 149       character*8 ndisqu, ndistr, ndisar, ndisno
 150       character*8 ntrav1, ntrav2, ntrav3, ntrav4
 151 c
 152       integer nbmess
 153       parameter ( nbmess = 10 )
 154       character*80 texte(nblang,nbmess)
 155 c
 156 c 0.5. ==> initialisations
 157 c
 158       nouvno = nbnoto
 159       nouvar = nbarto
 160       nouvtr = nbtrto
 161       nouvqu = nbquto
 162       nouvte = nbteto
 163       nouvtf = nouvte
 164       nouvhe = nbheto
 165       nouvhf = nouvhe
 166       nouvpe = nbpeto
 167       nouvpf = nouvpe
 168 c ______________________________________________________________________
 169 c
 170 c====
 171 c 1. messages
 172 c====
 173 c
 174       codava = codret
 175 c
 176 c=======================================================================
 177       if ( codava.eq.0 ) then
 178 c=======================================================================
 179 c
 180 c 1.3. ==> les messages
 181 c
 182 #include "impr01.h"
 183 c
 184 #ifdef _DEBUG_HOMARD_
 185       write (ulsort,texte(langue,1)) 'Entree', nompro
 186       call dmflsh (iaux)
 187 #endif
 188 c
 189       texte(1,4) = '(/,a6,'' DERAFFINEMENT STANDARD DU MAILLAGE'')'
 190       texte(1,5) = '(41(''=''),/)'
 191 c
 192       texte(2,4) = '(/,a6,'' STANDARD UNREFINEMENT OF MESH'')'
 193       texte(2,5) = '(36(''=''),/)'
 194 c
 195 c 1.4. ==> le numero de sous-etape
 196 c
 197       nretap = taetco(1)
 198       nrsset = taetco(2) + 1
 199       taetco(2) = nrsset
 200 c
 201       call utcvne ( nretap, nrsset, saux, iaux, codret )
 202 c
 203 c 1.5. ==> le titre
 204 c
 205       write (ulsort,texte(langue,4)) saux
 206       write (ulsort,texte(langue,5))
 207 c
 208 #include "impr03.h"
 209 c
 210 c====
 211 c 2. recuperation des pointeurs
 212 c====
 213 c
 214 c 2.1. ==> structure generale
 215 c
 216       if ( codret.eq.0 ) then
 217 c
 218 #ifdef _DEBUG_HOMARD_
 219       write (ulsort,90002) '2.1. ==> structure generale'
 220 #endif
 221 c
 222 #ifdef _DEBUG_HOMARD_
 223       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 224 #endif
 225 c
 226       call utnomh ( nomail,
 227      >                sdim,   mdim,
 228      >               degre, maconf, homolo, hierar,
 229      >              rafdef, nbmane, typcca, typsfr, maextr,
 230      >              mailet,
 231      >              norenu,
 232      >              nhnoeu, nhmapo, nharet,
 233      >              nhtria, nhquad,
 234      >              nhtetr, nhhexa, nhpyra, nhpent,
 235      >              nhelig,
 236      >              nhvois, nhsupe, nhsups,
 237      >              ulsort, langue, codret)
 238 c
 239       endif
 240 c
 241 c 2.2. ==> tableaux
 242 c
 243       if ( codret.eq.0 ) then
 244 c
 245 #ifdef _DEBUG_HOMARD_
 246       write (ulsort,90002) '2.2. ==> tableaux'
 247 #endif
 248 c
 249       iaux = 210
 250       if ( homolo.ge.1 ) then
 251         iaux = iaux*11
 252       endif
 253 #ifdef _DEBUG_HOMARD_
 254       write (ulsort,texte(langue,3)) 'UTAD01', nompro
 255 #endif
 256       call utad01 ( iaux, nhnoeu,
 257      >              phetno,
 258      >              pfamno, pcfano,   jaux,
 259      >              pcoono, pareno, adhono,  jaux,
 260      >              ulsort, langue, codret )
 261 c
 262       call gmnomc ( nomail//'.InfoSupE', nhsupe, codre0 )
 263 c
 264       codret = max ( abs(codre0), codret )
 265 c
 266       iaux = 210
 267       if ( degre.eq.2 ) then
 268         iaux = iaux*13
 269       endif
 270       if ( homolo.ge.2 ) then
 271         iaux = iaux*29
 272       endif
 273 #ifdef _DEBUG_HOMARD_
 274       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 275 #endif
 276       call utad02 ( iaux, nharet,
 277      >              phetar, psomar, pfilar, pmerar,
 278      >              pfamar,   jaux,   jaux,
 279      >                jaux, pnp2ar,   jaux,
 280      >                jaux, adhoar,   jaux,
 281      >              ulsort, langue, codret )
 282 c
 283       if ( nbtrto.ne.0 ) then
 284 c
 285         iaux = 2310
 286         if ( mod(mailet,2).eq.0 ) then
 287           iaux = iaux*19
 288         endif
 289         if ( homolo.ge.3 ) then
 290           iaux = iaux*29
 291         endif
 292 #ifdef _DEBUG_HOMARD_
 293       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 294 #endif
 295         call utad02 ( iaux, nhtria,
 296      >                phettr, paretr, pfiltr, ppertr,
 297      >                pfamtr,   jaux,   jaux,
 298      >                pnivtr,   jaux,   jaux,
 299      >                adnmtr, adhotr,   jaux,
 300      >                ulsort, langue, codret )
 301 c
 302       endif
 303 c
 304       if ( nbquto.ne.0 ) then
 305 c
 306         iaux = 2310
 307         if ( mod(mailet,3).eq.0 ) then
 308           iaux = iaux*19
 309         endif
 310         if ( homolo.ge.3 ) then
 311           iaux = iaux*29
 312         endif
 313 #ifdef _DEBUG_HOMARD_
 314       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 315 #endif
 316         call utad02 ( iaux, nhquad,
 317      >                phetqu, parequ, pfilqu, pperqu,
 318      >                pfamqu,   jaux,   jaux,
 319      >                pnivqu,   jaux,   jaux,
 320      >                adnmqu, adhoqu,   jaux,
 321      >                ulsort, langue, codret )
 322 c
 323       endif
 324 c
 325       if ( nbteto.ne.0 ) then
 326 c
 327         iaux = 2730
 328 #ifdef _DEBUG_HOMARD_
 329       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 330 #endif
 331         call utad02 ( iaux, nhtetr,
 332      >                phette, ptrite, pfilte, pperte,
 333      >                pfamte,   jaux,   jaux,
 334      >                  jaux, pcotrt,   jaux,
 335      >                  jaux,   jaux,   jaux,
 336      >                ulsort, langue, codret )
 337 c
 338       endif
 339 c
 340       if ( nbheto.ne.0 ) then
 341 c
 342         iaux = 2730
 343         if ( mod(mailet,5).eq.0 ) then
 344           iaux = iaux*19
 345         endif
 346 #ifdef _DEBUG_HOMARD_
 347       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 348 #endif
 349         call utad02 ( iaux, nhhexa,
 350      >                phethe, pquahe, pfilhe, pperhe,
 351      >                pfamhe,   jaux,   jaux,
 352      >                  jaux, pcoquh,   jaux,
 353      >                adnmhe,   jaux,   jaux,
 354      >                ulsort, langue, codret )
 355 c
 356       endif
 357 c
 358       if ( nbpeto.ne.0 ) then
 359 c
 360         iaux = 2730
 361 #ifdef _DEBUG_HOMARD_
 362       write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 363 #endif
 364         call utad02 ( iaux, nhpent,
 365      >                phetpe, pfacpe, pfilpe, pperpe,
 366      >                pfampe,   jaux,   jaux,
 367      >                  jaux, pcofap,   jaux,
 368      >                  jaux,   jaux,   jaux,
 369      >                ulsort, langue, codret )
 370 c
 371       endif
 372 c
 373       endif
 374 c
 375       if ( codret.eq.0 ) then
 376 c
 377       iaux = 3
 378 #ifdef _DEBUG_HOMARD_
 379       write (ulsort,texte(langue,3)) 'UTAD04', nompro
 380 #endif
 381       call utad04 ( iaux, nhvois,
 382      >                jaux,   jaux, pposif, pfacar,
 383      >                jaux,   jaux,
 384      >                jaux,   jaux,   jaux,   jaux,
 385      >                jaux,   jaux,   jaux,
 386      >                jaux,   jaux,   jaux,
 387      >                jaux,   jaux,   jaux,
 388      >                jaux,   jaux,   jaux,
 389      >              ulsort, langue, codret )
 390 c
 391       endif
 392 c
 393       if ( codret.eq.0 ) then
 394 c
 395       ntrav1 = taopts(11)
 396       call gmadoj ( ntrav1, pdecar, iaux, codre1 )
 397       ntrav2 = taopts(12)
 398       call gmadoj ( ntrav2, pdecfa, iaux, codre2 )
 399 c
 400       codre0 = min ( codre1, codre2 )
 401       codret = max ( abs(codre0), codret,
 402      >               codre1, codre2 )
 403 cgn      call gmprsx (nompro//'- DECARE', ntrav1)
 404 cgn      call gmprot (nompro//'- DECARE', ntrav1, 1659, 1662)
 405 cgn      if ( nbquto.eq.0 ) then
 406 cgn        call gmprot (nompro//'- DECFAC', ntrav2, 2, nbtrto+1)
 407 cgn      else
 408 cgn        call gmprsx (nompro//'- DECFAC', ntrav2)
 409 cgn      endif
 410 c
 411       endif
 412 c
 413 c 2.3. ==> allocations supplementaires
 414 c
 415 #ifdef _DEBUG_HOMARD_
 416       write (ulsort,90002) '2.3. alloc supplementaires ; codret', codret
 417 #endif
 418 c
 419 c 2.3.1. ==> Renumerotation des noeuds
 420 c
 421       if ( codret.eq.0 ) then
 422 c
 423       call gmobal ( nhnoeu//'.Deraffin', codre0 )
 424       if ( codre0.eq.2 ) then
 425         call gmadoj ( nhnoeu//'.Deraffin', pancno, iaux, codret )
 426         nbancn = iaux
 427       elseif ( codre0.eq.0 ) then
 428         call gmaloj ( nhnoeu//'.Deraffin', ' ', nouvno, pancno, codret )
 429         nbancn = nouvno
 430         if ( codret.eq.0 ) then
 431           do 231 , iaux = 1, nouvno
 432             imem(pancno+iaux-1) = iaux
 433   231     continue
 434         endif
 435       else
 436         codret = codre0
 437       endif
 438 c
 439       endif
 440 c
 441       if ( codret.eq.0 ) then
 442 c
 443       call gmaloj ( nharet//'.Deraffin', ' ', nouvar, pancar, codre1 )
 444       call gmaloj ( nhtria//'.Deraffin', ' ', nouvtr, panctr, codre2 )
 445       call gmaloj ( nhquad//'.Deraffin', ' ', nouvqu, pancqu, codre3 )
 446       call gmaloj ( nhtetr//'.Deraffin', ' ', nouvte, pancte, codre4 )
 447       call gmaloj ( nhhexa//'.Deraffin', ' ', nouvhe, panche, codre5 )
 448       call gmaloj ( nhpent//'.Deraffin', ' ', nouvpe, pancpe, codre6 )
 449       call gmaloj ( nhpyra//'.Deraffin', ' ', nouvpy, pancpy, codre7 )
 450 c
 451       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 452      >               codre6, codre7 )
 453       codret = max ( abs(codre0), codret,
 454      >               codre1, codre2, codre3, codre4, codre5,
 455      >               codre6, codre7 )
 456 c
 457       iaux = nbnoto + 1
 458       call gmalot ( nnouno, 'entier  ', iaux, pnouno, codre1 )
 459       iaux = nbarto + 1
 460       call gmalot ( nnouar, 'entier  ', iaux, pnouar, codre2 )
 461       iaux = nbtrto + 1
 462       call gmalot ( nnoutr, 'entier  ', iaux, pnoutr, codre3 )
 463       iaux = nbquto + 1
 464       call gmalot ( nnouqu, 'entier  ', iaux, pnouqu, codre4 )
 465       iaux = nbteto+1
 466       call gmalot ( nnoute, 'entier  ', iaux, pnoute, codre5 )
 467       iaux = nbheto+1
 468       call gmalot ( nnouhe, 'entier  ', iaux, pnouhe, codre6 )
 469       iaux = nbpeto+1
 470       call gmalot ( nnoupe, 'entier  ', iaux, pnoupe, codre7 )
 471       iaux = nbpyto+1
 472       call gmalot ( nnoupy, 'entier  ', iaux, pnoupy, codre8 )
 473 c
 474       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 475      >               codre6, codre7, codre8 )
 476       codret = max ( abs(codre0), codret,
 477      >               codre1, codre2, codre3, codre4, codre5,
 478      >               codre6, codre7, codre8 )
 479 c
 480       call gmalot ( ndisno, 'entier  ', nouvno, pdisno, codre1 )
 481       call gmalot ( ndisar, 'entier  ', nouvar, pdisar, codre2 )
 482       call gmalot ( ndistr, 'entier  ', nouvtr, pdistr, codre3 )
 483       call gmalot ( ndisqu, 'entier  ', nouvqu, pdisqu, codre4 )
 484       call gmalot ( ndiste, 'entier  ', nouvte, pdiste, codre5 )
 485       call gmalot ( ndishe, 'entier  ', nouvhe, pdishe, codre6 )
 486       call gmalot ( ndispe, 'entier  ', nouvpe, pdispe, codre7 )
 487       call gmalot ( ndispy, 'entier  ', nouvpy, pdispy, codre8 )
 488 c
 489       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 490      >               codre6, codre7, codre8 )
 491       codret = max ( abs(codre0), codret,
 492      >               codre1, codre2, codre3, codre4, codre5,
 493      >               codre6, codre7, codre8 )
 494 c
 495       iaux = max ( nbarto, nbtrto, nbquto, nbteto, nbheto, nbpeto )
 496       call gmalot ( ntrav3, 'entier  ', iaux, ptrav3, codre1 )
 497       call gmalot ( ntrav4, 'entier  ', iaux, ptrav4, codre2 )
 498 c
 499       codre0 = min ( codre1, codre2 )
 500       codret = max ( abs(codre0), codret,
 501      >               codre1, codre2 )
 502 c
 503       endif
 504 c
 505 c====
 506 c 3. regroupement des entites
 507 c====
 508 c
 509 c 3.1. ==> initialisation des tableaux de "disparition"
 510 c     Par convention, une valeur 0 indique la conservation et
 511 c     une autre valeur la disparition de l'entite concernee par la liste
 512 c
 513 #ifdef _DEBUG_HOMARD_
 514       write (ulsort,90002) '3.1. Init tableaux disp ; codret', codret
 515 #endif
 516 c
 517       if ( codret.eq.0 ) then
 518 c
 519       ideb = pdisno
 520       ifin = pdisno + nouvno - 1
 521       do 311 , iaux = ideb , ifin
 522         imem(iaux) = 0
 523   311 continue
 524 c
 525       ideb = pdisar
 526       ifin = pdisar + nouvar - 1
 527       do 312 , iaux = ideb , ifin
 528         imem(iaux) = 0
 529   312 continue
 530 c
 531       ideb = pdistr
 532       ifin = pdistr + nouvtr - 1
 533       do 313 , iaux = ideb , ifin
 534         imem(iaux) = 0
 535   313 continue
 536 c
 537       ideb = pdisqu
 538       ifin = pdisqu + nouvqu - 1
 539       do 314 , iaux = ideb , ifin
 540         imem(iaux) = 0
 541   314 continue
 542 c
 543       ideb = pdiste
 544       ifin = pdiste + nouvte - 1
 545       do 315 , iaux = ideb , ifin
 546         imem(iaux) = 0
 547   315 continue
 548 c
 549       ideb = pdishe
 550       ifin = pdishe + nouvhe - 1
 551       do 316 , iaux = ideb , ifin
 552         imem(iaux) = 0
 553  316  continue
 554 c
 555       ideb = pdispe
 556       ifin = pdispe + nouvpe - 1
 557       do 317 , iaux = ideb , ifin
 558         imem(iaux) = 0
 559  317  continue
 560 c
 561       ideb = pdispy
 562       ifin = pdispy + nouvpy - 1
 563       do 318 , iaux = ideb , ifin
 564         imem(iaux) = 0
 565  318  continue
 566 c
 567       endif
 568 c
 569 c 3.2. ==> regroupement des tetraedres
 570 #ifdef _DEBUG_HOMARD_
 571       write (ulsort,90002) '3.2 regroupement tetr ; codret', codret
 572 #endif
 573 c
 574       if ( codret.eq.0 ) then
 575 c
 576       if ( nbteto.ne.0 ) then
 577 c
 578 #ifdef _DEBUG_HOMARD_
 579       write (ulsort,texte(langue,3)) 'CMDRTE', nompro
 580 #endif
 581 c
 582       call cmdrte (
 583      >         imem(paretr), imem(pdecfa),
 584      >         imem(ptrite), imem(phette),
 585      >         imem(pfilte), imem(pdisar), imem(pdistr), imem(pdiste),
 586      >         imem(pareno), imem(psomar), imem(pcotrt), imem(pdisno),
 587      >         imem(pnp2ar), imem(ppertr), codret )
 588 c
 589       endif
 590 c
 591       endif
 592 c
 593 c 3.3. ==> regroupement des hexaedres
 594 #ifdef _DEBUG_HOMARD_
 595       write (ulsort,90002) '3.3 regroupement hexa ; codret', codret
 596 #endif
 597 c
 598       if ( codret.eq.0 ) then
 599 c
 600       if ( nbheto.ne.0 ) then
 601 c
 602 #ifdef _DEBUG_HOMARD_
 603       write (ulsort,texte(langue,3)) 'CMDRHE', nompro
 604 #endif
 605 c
 606       call cmdrhe (
 607      >         imem(parequ), imem(pdecfa),
 608      >         imem(pquahe), imem(phethe),
 609      >         imem(pfilhe), imem(pdisar), imem(pdisqu), imem(pdishe),
 610      >         imem(psomar), imem(pdisno),
 611      >         imem(pnp2ar), codret )
 612 c
 613       endif
 614 c
 615       endif
 616 c
 617 c 3.4. ==> regroupement des pentaedres
 618 #ifdef _DEBUG_HOMARD_
 619       write (ulsort,90002) '3.4 regroupement pent ; codret', codret
 620 #endif
 621 c
 622       if ( codret.eq.0 ) then
 623 c
 624       if ( nbpeto.ne.0 ) then
 625 c
 626 #ifdef _DEBUG_HOMARD_
 627       write (ulsort,texte(langue,3)) 'CMDRPE', nompro
 628 #endif
 629 c
 630       call cmdrpe (
 631      >         imem(paretr), imem(pdecfa),
 632      >         imem(pfacpe), imem(phetpe),
 633      >         imem(pfilpe),
 634      >         imem(pdisar), imem(pdistr), imem(pdisqu), imem(pdispe),
 635      >         imem(pdisno),
 636      >         imem(pnp2ar), codret )
 637 c
 638       endif
 639 c
 640       endif
 641 c
 642 c 3.5. ==> regroupement des triangles
 643 #ifdef _DEBUG_HOMARD_
 644       write (ulsort,90002) '3.5 regroupement tria ; codret', codret
 645 #endif
 646 c
 647       if ( codret.eq.0 ) then
 648 c
 649       if ( nbtrto.ne.0 ) then
 650 c
 651 #ifdef _DEBUG_HOMARD_
 652       write (ulsort,texte(langue,3)) 'CMDRTR', nompro
 653 #endif
 654 c
 655       call cmdrtr (
 656      >         imem(paretr), imem(pdecfa),
 657      >         imem(phettr), imem(pfiltr), imem(adnmtr),
 658      >         imem(pdisno), imem(pdisar), imem(pdistr), imem(pdisqu),
 659      >         imem(pdecar), imem(pfilar),
 660      >         imem(pnp2ar), imem(pposif), imem(pfacar), imem(psomar),
 661      >         imem(phetno), codret )
 662 c
 663       endif
 664 c
 665       endif
 666 c
 667 c 3.6. ==> regroupement des quadrangles
 668 #ifdef _DEBUG_HOMARD_
 669       write (ulsort,90002) '3.6 regroupement quad ; codret', codret
 670 #endif
 671 c
 672       if ( codret.eq.0 ) then
 673 c
 674       if ( nbquto.ne.0 ) then
 675 c
 676 #ifdef _DEBUG_HOMARD_
 677       write (ulsort,texte(langue,3)) 'CMDRQU', nompro
 678 #endif
 679 c
 680       call cmdrqu (
 681      >         imem(parequ), imem(pdecfa),
 682      >         imem(phetqu), imem(pfilqu), imem(adnmqu),
 683      >         imem(pdisno), imem(pdisar), imem(pdistr), imem(pdisqu),
 684      >         imem(pdecar), imem(pfilar),
 685      >         imem(pnp2ar), imem(pposif), imem(pfacar), imem(psomar),
 686      >         imem(phetno), codret )
 687 c
 688       endif
 689 c
 690       endif
 691 c
 692 c 3.7. ==> regroupement des aretes
 693 #ifdef _DEBUG_HOMARD_
 694       write (ulsort,90002) '3.7 regroupement aret ; codret', codret
 695 #endif
 696 c
 697       if ( codret.eq.0 ) then
 698 c
 699 #ifdef _DEBUG_HOMARD_
 700       write (ulsort,texte(langue,3)) 'CMDRAR', nompro
 701 #endif
 702 c
 703       call cmdrar (
 704      >         imem(phetar), imem(pfilar), imem(pnp2ar), imem(psomar),
 705      >         imem(pdecar),
 706      >         imem(pdisar), imem(pdisno), imem(pdistr), imem(pdisqu),
 707      >         imem(phetno), imem(pposif), imem(pfacar), codret )
 708 c
 709       endif
 710 c
 711 c====
 712 c 4. suppression des entites
 713 c====
 714 c
 715 c 4.1. ==> suppression des tetraedres
 716 #ifdef _DEBUG_HOMARD_
 717       write (ulsort,90002) '4.1. suppression tetr ; codret', codret
 718 #endif
 719 c
 720       if ( codret.eq.0 ) then
 721 c
 722       if ( nbteto.ne.0 ) then
 723 c
 724 #ifdef _DEBUG_HOMARD_
 725         write (ulsort,texte(langue,3)) 'UTSUTE', nompro
 726 #endif
 727 c
 728         call utsute ( imem(pdiste),
 729      >                imem(phette), imem(pperte), imem(pfilte),
 730      >                imem(ptrite), imem(pcotrt),
 731      >                imem(pareno), imem(psomar), imem(paretr),
 732      >                imem(pancte), imem(pnoute),
 733      >                nbtere,
 734      >                codret )
 735 c
 736         indtet = nbtere
 737 c
 738       else
 739 c
 740         indtet = 0
 741 c
 742       endif
 743 c
 744       endif
 745 c
 746 c 4.2. ==> suppression des hexaedres
 747 #ifdef _DEBUG_HOMARD_
 748       write (ulsort,90002) '4.2. suppression hexa ; codret', codret
 749 #endif
 750 c
 751       if ( codret.eq.0 ) then
 752 c
 753       if ( nbheto.ne.0 ) then
 754 c
 755 #ifdef _DEBUG_HOMARD_
 756         write (ulsort,texte(langue,3)) 'UTSUHE', nompro
 757 #endif
 758 c
 759         call utsuhe ( imem(pdishe),
 760      >                imem(phethe), imem(pperhe), imem(pfilhe),
 761      >                imem(panche), imem(pnouhe),
 762      >                nbhere )
 763 c
 764         indhex = nbhere
 765 c
 766       else
 767 c
 768         indhex = 0
 769 c
 770       endif
 771 c
 772       endif
 773 c
 774 c 4.3. ==> suppression des pentaedres
 775 #ifdef _DEBUG_HOMARD_
 776       write (ulsort,90002) '4.3. suppression pent ; codret', codret
 777 #endif
 778 c
 779       if ( codret.eq.0 ) then
 780 c
 781       if ( nbpeto.ne.0 ) then
 782 c
 783 #ifdef _DEBUG_HOMARD_
 784         write (ulsort,texte(langue,3)) 'UTSUPE', nompro
 785 #endif
 786 c
 787         call utsupe ( imem(pdispe),
 788      >                imem(phetpe), imem(pperpe), imem(pfilpe),
 789      >                imem(pancpe), imem(pnoupe),
 790      >                nbpere )
 791 c
 792         indpen = nbpere
 793 c
 794       else
 795 c
 796         indpen = 0
 797 c
 798       endif
 799 c
 800       endif
 801 c
 802 c 4.4. ==> suppression des triangles
 803 #ifdef _DEBUG_HOMARD_
 804       write (ulsort,90002) '4.4. suppression tria ; codret', codret
 805 #endif
 806 c
 807       if ( codret.eq.0 ) then
 808 c
 809       if ( nbtrto.ne.0 ) then
 810 c
 811 #ifdef _DEBUG_HOMARD_
 812         write (ulsort,texte(langue,3)) 'UTSUTR', nompro
 813 #endif
 814 c
 815         call utsutr ( imem(pdistr),
 816      >                imem(phettr), imem(ppertr), imem(pfiltr),
 817      >                imem(panctr), imem(pnoutr),
 818      >                nbtrre )
 819 c
 820         indtri = nbtrre
 821 c
 822       else
 823 c
 824         indtri = 0
 825 c
 826       endif
 827 c
 828       endif
 829 c
 830 c 4.5. ==> suppression des quadrangles
 831 #ifdef _DEBUG_HOMARD_
 832       write (ulsort,90002) '4.5. suppression quad ; codret', codret
 833 #endif
 834 c
 835       if ( codret.eq.0 ) then
 836 c
 837       if ( nbquto.ne.0 ) then
 838 c
 839 #ifdef _DEBUG_HOMARD_
 840         write (ulsort,texte(langue,3)) 'UTSUQU', nompro
 841 #endif
 842 c
 843         call utsuqu ( imem(pdisqu),
 844      >                imem(phetqu), imem(pperqu), imem(pfilqu),
 845      >                imem(pancqu), imem(pnouqu),
 846      >                nbqure )
 847 c
 848         indqua = nbqure
 849 c
 850       else
 851 c
 852         indqua = 0
 853 c
 854       endif
 855 c
 856       endif
 857 c
 858 c 4.6. ==> suppression des aretes
 859 #ifdef _DEBUG_HOMARD_
 860       write (ulsort,90002) '4.6. suppression aret ; codret', codret
 861 #endif
 862 c
 863       if ( codret.eq.0 ) then
 864 c
 865 #ifdef _DEBUG_HOMARD_
 866       write (ulsort,texte(langue,3)) 'UTSUAR', nompro
 867 #endif
 868 c
 869       call utsuar ( imem(pdisar),
 870      >              imem(phetar), imem(pmerar), imem(pfilar),
 871      >              imem(pancar), imem(pnouar),
 872      >              nbarre )
 873 c
 874       indare = nbarre
 875 c
 876       endif
 877 c
 878 c 4.7. ==> suppression des noeuds
 879 #ifdef _DEBUG_HOMARD_
 880       write (ulsort,90002) '4.7. suppression noeuds ; codret', codret
 881 #endif
 882 c
 883       if ( codret.eq.0 ) then
 884 c
 885 #ifdef _DEBUG_HOMARD_
 886       write (ulsort,texte(langue,3)) 'UTSUNO', nompro
 887 #endif
 888 c
 889       call utsuno ( nbnoto, nouvno, imem(pdisno),
 890      >              imem(phetno), imem(pancno), imem(pnouno),
 891      >              nbnore, nbp2re, nbimre )
 892 c
 893       indnoe = nbnore
 894       indnp2 = nbp2re
 895       indnim = nbimre
 896 c
 897       endif
 898 c
 899 c====
 900 c 5. compactage des numerotations
 901 c====
 902 c
 903 c 5.1. ==> compactage des tetraedres
 904 #ifdef _DEBUG_HOMARD_
 905       write (ulsort,90002) '5.1. compactage tetr ; codret', codret
 906 #endif
 907 c
 908       if ( codret.eq.0 ) then
 909 c
 910       if ( nbteto.ne.0 ) then
 911 c
 912 #ifdef _DEBUG_HOMARD_
 913         write (ulsort,texte(langue,3)) 'UTCNTE', nompro
 914 #endif
 915 c
 916         call utcnte (
 917      >         imem(ptrite), imem(pcotrt), imem(phette), imem(pfamte),
 918      >         imem(pfilte), imem(pperte), imem(pancte), imem(pnoute),
 919      >         imem(pnoutr), nbtere,
 920      >         imem(ptrav3), imem(ptrav4) )
 921 c
 922       endif
 923 c
 924       endif
 925
 926 c
 927 c 5.2. ==> compactage des hexaedres
 928 #ifdef _DEBUG_HOMARD_
 929       write (ulsort,90002) '5.2. compactage hexa ; codret', codret
 930 #endif
 931 c
 932       if ( codret.eq.0 ) then
 933 c
 934       if ( nbheto.ne.0 ) then
 935 c
 936 #ifdef _DEBUG_HOMARD_
 937         write (ulsort,texte(langue,3)) 'UTCNHE', nompro
 938 #endif
 939         call utcnhe (
 940      >         imem(pquahe), imem(pcoquh), imem(phethe), imem(pfamhe),
 941      >         imem(pfilhe), imem(pperhe), imem(adnmqu),
 942      >         imem(panche), imem(pnouhe),
 943      >         imem(pnouqu), nbhere,
 944      >         imem(ptrav3), imem(ptrav4) )
 945 c
 946       endif
 947 c
 948       endif
 949 c
 950 c 5.3. ==> compactage des pentaedres
 951 #ifdef _DEBUG_HOMARD_
 952       write (ulsort,90002) '5.3. compactage pent ; codret', codret
 953 #endif
 954 c
 955       if ( codret.eq.0 ) then
 956 c
 957       if ( nbpeto.ne.0 ) then
 958 c
 959 #ifdef _DEBUG_HOMARD_
 960         write (ulsort,texte(langue,3)) 'UTCNPE', nompro
 961 #endif
 962         call utcnpe (
 963      >         imem(pfacpe), imem(pcofap), imem(phetpe), imem(pfampe),
 964      >         imem(pfilpe), imem(pperpe), imem(pancpe), imem(pnoupe),
 965      >         imem(pnoutr), imem(pnouqu), nbpere,
 966      >         imem(ptrav3), imem(ptrav4) )
 967 c
 968       endif
 969 c
 970       endif
 971 c
 972 c 5.4. ==> compactage des triangles
 973 #ifdef _DEBUG_HOMARD_
 974       write (ulsort,90002) '5.4. compactage tria ; codret', codret
 975 #endif
 976 c
 977       if ( codret.eq.0 ) then
 978 c
 979       if ( nbtrto.ne.0 ) then
 980 c
 981         iaux = 1
 982         if ( mod(mailet,2).eq.0 ) then
 983           iaux = iaux*2
 984         endif
 985         if ( homolo.ge.3 ) then
 986           iaux = iaux*5
 987         endif
 988 #ifdef _DEBUG_HOMARD_
 989         write (ulsort,texte(langue,3)) 'UTCNTR', nompro
 990 #endif
 991         call utcntr ( iaux,
 992      >         imem(phettr), imem(pfamtr), imem(pdecfa), imem(pnivtr),
 993      >         imem(pfiltr), imem(ppertr),
 994      >         tbiaux, imem(adnmtr), imem(adhotr),
 995      >         tbiaux, tbiaux,
 996      >         imem(panctr), imem(pnoutr), imem(pnouar), imem(paretr),
 997      >               nbtrre,
 998      >         imem(ptrav3), imem(ptrav4) )
 999 c
1000       endif
1001 c
1002       endif
1003 c
1004 c 5.5. ==> compactage des quadrangles
1005 #ifdef _DEBUG_HOMARD_
1006       write (ulsort,90002) '5.5. compactage quad ; codret', codret
1007 #endif
1008 c
1009       if ( codret.eq.0 ) then
1010 c
1011       if ( nbquto.ne.0 ) then
1012 c
1013         iaux = 1
1014         if ( mod(mailet,3).eq.0 ) then
1015           iaux = iaux*3
1016         endif
1017         if ( homolo.ge.3 ) then
1018           iaux = iaux*5
1019         endif
1020 #ifdef _DEBUG_HOMARD_
1021         write (ulsort,texte(langue,3)) 'UTCNQU', nompro
1022 #endif
1023         call utcnqu ( iaux,
1024      >         imem(phetqu), imem(pfamqu), imem(pdecfa), imem(pnivqu),
1025      >         imem(pfilqu), imem(pperqu),
1026      >         tbiaux, imem(adnmqu),
1027      >         tbiaux, tbiaux,
1028      >         imem(pancqu), imem(pnouqu), imem(pnouar), imem(parequ),
1029      >               nbqure,
1030      >         imem(ptrav3), imem(ptrav4) )
1031 c
1032       endif
1033 c
1034       endif
1035 c
1036 c 5.6. ==> compactage des aretes
1037 #ifdef _DEBUG_HOMARD_
1038       write (ulsort,90002) '5.6. compactage aret ; codret', codret
1039 #endif
1040 c
1041       if ( codret.eq.0 ) then
1042 c
1043 #ifdef _DEBUG_HOMARD_
1044       write (ulsort,texte(langue,3)) 'UTCNAR', nompro
1045 #endif
1046       call utcnar (
1047      >         imem(psomar), imem(phetar), imem(pfamar), imem(pdecar),
1048      >         imem(pfilar), imem(pmerar), imem(adhoar), imem(pnp2ar),
1049      >         imem(paretr), imem(parequ),
1050      >         imem(pposif), imem(pfacar),
1051      >         imem(pancar), imem(pnouar), imem(pnouno),
1052      >         nbtrre, nbqure, nbarre,
1053      >         imem(ptrav3), imem(ptrav4) )
1054 c
1055       endif
1056 c
1057 c 5.7. ==> compactage des noeuds
1058 #ifdef _DEBUG_HOMARD_
1059       write (ulsort,90002) '5.7. compactage noeuds ; codret', codret
1060 #endif
1061 c
1062       if ( codret.eq.0 ) then
1063 c
1064       iaux = 1
1065       if ( mod(mailet,2).eq.0 ) then
1066         iaux = iaux*2
1067       endif
1068       if ( mod(mailet,3).eq.0 ) then
1069         iaux = iaux*3
1070       endif
1071       if ( homolo.ge.1 ) then
1072         iaux = iaux*5
1073       endif
1074 #ifdef _DEBUG_HOMARD_
1075       write (ulsort,texte(langue,3)) 'UTCNNO', nompro
1076 #endif
1077       call utcnno ( iaux,
1078      >         rmem(pcoono),
1079      >         imem(phetno), imem(pfamno), imem(pareno), imem(adhono),
1080      >         tbiaux, tbiaux,
1081      >         imem(adnmtr),
1082      >         imem(adnmqu),
1083      >         imem(pnouar), imem(pnouno), nbnoto )
1084 c
1085 c
1086       endif
1087 c
1088 c====
1089 c 6. Menage
1090 c====
1091 #ifdef _DEBUG_HOMARD_
1092       write (ulsort,90002) '6. Menage ; codret', codret
1093 #endif
1094 c
1095       if ( codret.eq.0 ) then
1096 c
1097       call gmlboj ( nnouno, codre1 )
1098       call gmlboj ( nnouar, codre2 )
1099       call gmlboj ( nnoutr, codre3 )
1100       call gmlboj ( nnouqu, codre4 )
1101       call gmlboj ( nnoute, codre5 )
1102       call gmlboj ( nnouhe, codre6 )
1103       call gmlboj ( nnoupe, codre7 )
1104       call gmlboj ( nnoupy, codre8 )
1105 c
1106       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
1107      >               codre6, codre7, codre8 )
1108       codret = max ( abs(codre0), codret,
1109      >               codre1, codre2, codre3, codre4, codre5,
1110      >               codre6, codre7, codre8 )
1111 c
1112       call gmlboj ( ndisno, codre1 )
1113       call gmlboj ( ndisar, codre2 )
1114       call gmlboj ( ndistr, codre3 )
1115       call gmlboj ( ndisqu, codre4 )
1116       call gmlboj ( ndiste, codre5 )
1117       call gmlboj ( ndishe, codre6 )
1118       call gmlboj ( ndispe, codre7 )
1119       call gmlboj ( ndispy, codre8 )
1120 c
1121       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
1122      >               codre6, codre7, codre8 )
1123       codret = max ( abs(codre0), codret,
1124      >               codre1, codre2, codre3, codre4, codre5,
1125      >               codre6, codre7, codre8 )
1126 c
1127       call gmlboj ( ntrav3, codre1 )
1128       call gmlboj ( ntrav4, codre2 )
1129 c
1130       codre0 = min ( codre1, codre2 )
1131       codret = max ( abs(codre0), codret,
1132      >               codre1, codre2 )
1133 c
1134       endif
1135 c
1136 c====
1137 c 7. la fin
1138 c====
1139 c
1140       if ( codret.ne.0 ) then
1141 c
1142 #include "envex2.h"
1143 c
1144       write (ulsort,texte(langue,1)) 'Sortie', nompro
1145       write (ulsort,texte(langue,2)) codret
1146 c
1147       endif
1148 c
1149 #ifdef _DEBUG_HOMARD_
1150       write (ulsort,texte(langue,1)) 'Sortie', nompro
1151       call dmflsh (iaux)
1152 #endif
1153 c
1154 c=======================================================================
1155       endif
1156 c=======================================================================
1157 c
1158       end