src/tool/Modification/mmagre.F

   1       subroutine mmagre ( lgopti, taopti, lgetco, taetco,
   2      >                    nomail,
   3      >                    ulsort, langue, codret )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c  Modification de Maillage - AGREgat
  25 c  -               -          ----
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . lgopti . e   .   1    . longueur du tableau des options entieres   .
  31 c . taopti . e   . lgopti . tableau des options entieres               .
  32 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  33 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  34 c . nomail . e   . char8  . nom de l'objet maillage homard iter. n     .
  35 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  36 c . langue . e   .    1   . langue des messages                        .
  37 c .        .     .        . 1 : francais, 2 : anglais                  .
  38 c . codret . es  .    1   . code de retour des modules                 .
  39 c .        .     .        . 0 : pas de probleme                        .
  40 c .        .     .        . 1 : probleme                               .
  41 c ______________________________________________________________________
  42 c
  43 c====
  44 c 0. declarations et dimensionnement
  45 c====
  46 c
  47 c 0.1. ==> generalites
  48 c
  49       implicit none
  50       save
  51 c
  52       character*6 nompro
  53       parameter ( nompro = 'MMAGRE' )
  54 c
  55 #include "nblang.h"
  56 c
  57 c 0.2. ==> communs
  58 c
  59 #include "envex1.h"
  60 c
  61 #include "gmenti.h"
  62 #include "gmreel.h"
  63 #include "gmstri.h"
  64 c
  65 #include "impr02.h"
  66 c
  67 #include "envca1.h"
  68 #include "envada.h"
  69 c
  70 #include "nbfami.h"
  71 #include "nombno.h"
  72 #include "nombar.h"
  73 #include "nombtr.h"
  74 #include "nombte.h"
  75 #include "nombqu.h"
  76 #include "nombpe.h"
  77 #include "nombhe.h"
  78 c
  79 c 0.3. ==> arguments
  80 c
  81       integer lgopti
  82       integer taopti(lgopti)
  83 c
  84       integer ulsort, langue, codret
  85       integer lgetco
  86       integer taetco(lgetco)
  87 c
  88       character*8 nomail
  89 c
  90 c 0.4. ==> variables locales
  91 c
  92       integer nrosec
  93       integer iaux, jaux
  94       integer nretap, nrsset
  95       integer codre1, codre2, codre3, codre4, codre5
  96       integer codre6
  97       integer codre0
  98 c
  99       integer nuroul, lnomfl
 100       integer degre0
 101       integer nbnotn, nbartn, nbtrtn, nbqutn, nbtetn, nbpetn, nbhetn
 102       integer pcoono, phetno, pareno, pderno
 103       integer ppovos, pvoiso
 104       integer pposif, pfacar
 105       integer phetar, pfilar, pmerar, psomar
 106       integer phettr, pfiltr, ppertr, pnivtr, paretr
 107       integer phetqu, pfilqu, pperqu, pnivqu, parequ
 108       integer phette, ptrite, pcotrt, pfilte, pperte
 109       integer pquahe, pcoquh, phethe, pfilhe, pperhe
 110       integer pfacpe, pcofap, phetpe, pfilpe, pperpe
 111       integer pfamno
 112       integer pfamar
 113       integer pfamtr
 114       integer pfamqu
 115       integer pfamte, pcfate
 116       integer pfampe, pcfape
 117       integer pfamhe, pcfahe
 118       integer advotr, advoqu
 119       integer lgpptr, lgppqu, adpptr, adppqu
 120       integer ptrav1, ptrav2, ptrav3, ptrav4
 121       integer ptra30, ptra40, ptra31, ptra41
 122       integer ptra51, ptra52, ptra53
 123       integer ptraat, ptrant
 124       integer ptraaa, ptrana
 125       integer ptraan, ptrann
 126       integer nbduno, nbduar, nbdutr
 127       integer nbjois, nbpejs
 128       integer nbjoit, nbpejt, nbtrjt
 129       integer nbjoiq, nbhejq, nbqujq
 130       integer nbjp06, nbte06
 131       integer nbjp09, nbpe09
 132       integer nbjp12, nbhe12
 133       integer nbvojm, nbjoto
 134       integer voarno, vofaar, vovoar, vovofa
 135       integer ptra17, ptra18
 136       integer ptraw1, ptraw2, ptraw6
 137       integer nbgrfm, nbfmed, ngrouc
 138       integer adnumf
 139       integer adpoin, adtail, adtabl
 140 c
 141       character*6 saux
 142       character*8 action
 143       character*8 norenu
 144       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 145       character*8 nhtetr, nhhexa, nhpyra, nhpent
 146       character*8 nhelig
 147       character*8 nhvois, nhsupe, nhsups
 148       character*8 ntrav1, ntrav2, ntrav3, ntrav4
 149       character*8 ntra30, ntra40, ntra31, ntra41
 150       character*8 ntra51, ntra52, ntra53
 151       character*8 ntraat, ntrant
 152       character*8 ntraaa, ntrana
 153       character*8 ntraan, ntrann
 154       character*8 ntra17, ntra18
 155       character*8 ntraw1, ntraw2, ntraw6
 156       character*200 nomflo
 157 c
 158       double precision shrink
 159 c
 160       integer nbmess
 161       parameter ( nbmess = 10 )
 162       character*80 texte(nblang,nbmess)
 163 c
 164 c 0.5. ==> initialisations
 165 c ______________________________________________________________________
 166 c
 167 c====
 168 c 1. messages
 169 c====
 170 c
 171 c 1.1. ==> le debut des mesures de temps
 172 c
 173       nrosec = taetco(4)
 174       call gtdems (nrosec)
 175 c
 176 c 1.3. ==> les messages
 177 c
 178 #include "impr01.h"
 179 c
 180 #ifdef _DEBUG_HOMARD_
 181       write (ulsort,texte(langue,1)) 'Entree', nompro
 182       call dmflsh (iaux)
 183 #endif
 184 c
 185       texte(1,4) = '(/,a6,'' MAILLES DE JOINTS'')'
 186       texte(1,5) = '(24(''=''),/)'
 187       texte(1,7) = '(5x,''Nombre de '',a,'' a creer     :'',i8)'
 188       texte(1,8) = '(5x,''Nombre de '',a,'' a dupliquer :'',i8)'
 189 c
 190       texte(2,4) = '(/,a6,'' MESHES FOR THE JUNCTIONS'')'
 191       texte(2,5) = '(31(''=''),/)'
 192       texte(2,7) = '(5x,''Number of '',a,'' to create    :'',i8)'
 193       texte(2,8) = '(5x,''Number of '',a,'' to duplicate :'',i8)'
 194 c
 195 #include "impr03.h"
 196 c
 197 c 1.4. ==> le numero de sous-etape
 198 c
 199       nretap = taetco(1)
 200       nrsset = taetco(2) + 1
 201       taetco(2) = nrsset
 202 c
 203       call utcvne ( nretap, nrsset, saux, iaux, codret )
 204 c
 205 c 1.5 ==> le titre
 206 c
 207       write (ulsort,texte(langue,4)) saux
 208       write (ulsort,texte(langue,5))
 209 c
 210 c====
 211 c 1.bis. fichier de sortie du bilan
 212 c====
 213 #ifdef _DEBUG_HOMARD_
 214       write (ulsort,*) '1.bis. fichier bilan codret = ', codret
 215 #endif
 216 c
 217       if ( codret.eq.0 ) then
 218 c
 219 #ifdef _DEBUG_HOMARD_
 220       write (ulsort,texte(langue,3)) 'UTULBI', nompro
 221 #endif
 222       action = 'modi    '
 223       iaux = 1
 224       jaux = -1
 225       call utulbi ( nuroul, nomflo, lnomfl,
 226      >                iaux, action, nbiter, jaux,
 227      >              ulsort, langue, codret )
 228 c
 229       endif
 230 c
 231 c====
 232 c 2. conversion eventuelle en degre 1
 233 c====
 234 #ifdef _DEBUG_HOMARD_
 235       write (ulsort,*) '2. conversion  en degre 1 ; codret = ', codret
 236 #endif
 237 c
 238       if ( codret.eq.0 ) then
 239 c
 240       call gmliat ( nomail, 3, degre0 , codret )
 241 c
 242       endif
 243 c
 244       if ( degre0.eq.2 ) then
 245         call gtdems (60)
 246 c
 247         if ( codret.eq.0 ) then
 248 c
 249 #ifdef _DEBUG_HOMARD_
 250       write (ulsort,texte(langue,3)) 'mmdeg0', nompro
 251 #endif
 252 c
 253         call mmdeg0 ( nomail,
 254      >                ulsort, langue, codret )
 255 c
 256         endif
 257 c
 258         call gtfims (60)
 259       endif
 260 c
 261 c====
 262 c 3. structure generale
 263 c====
 264 #ifdef _DEBUG_HOMARD_
 265       write (ulsort,*) '3. structure generale ; codret = ', codret
 266 #endif
 267 c
 268       if ( codret.eq.0 ) then
 269 c
 270 #ifdef _DEBUG_HOMARD_
 271       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 272 #endif
 273 c
 274       call utnomh ( nomail,
 275      >                sdim,   mdim,
 276      >               degre, maconf, homolo, hierar,
 277      >              rafdef, nbmane, typcca, typsfr, maextr,
 278      >              mailet,
 279      >              norenu,
 280      >              nhnoeu, nhmapo, nharet,
 281      >              nhtria, nhquad,
 282      >              nhtetr, nhhexa, nhpyra, nhpent,
 283      >              nhelig,
 284      >              nhvois, nhsupe, nhsups,
 285      >              ulsort, langue, codret)
 286 c
 287       endif
 288 c
 289 c 3.2. ==> Tableaux
 290 c
 291       if ( codret.eq.0 ) then
 292 c
 293       iaux = 210
 294 #ifdef _DEBUG_HOMARD_
 295       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 296 #endif
 297       call utad02 (   iaux, nharet,
 298      >              phetar, psomar, pfilar, pmerar,
 299      >              pfamar,   jaux,   jaux,
 300      >                jaux,   jaux,   jaux,
 301      >                jaux,   jaux,   jaux,
 302      >              ulsort, langue, codret )
 303 c
 304       iaux = 2310
 305 #ifdef _DEBUG_HOMARD_
 306       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 307 #endif
 308       call utad02 (   iaux, nhtria,
 309      >              phettr, paretr, pfiltr, ppertr,
 310      >              pfamtr,   jaux,   jaux,
 311      >              pnivtr,   jaux,   jaux,
 312      >                jaux,   jaux,   jaux,
 313      >              ulsort, langue, codret )
 314 c
 315       iaux = 6734
 316 #ifdef _DEBUG_HOMARD_
 317       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 318 #endif
 319       call utad02 (   iaux, nhtetr,
 320      >              phette, ptrite,  jaux, jaux,
 321      >              pfamte, pcfate,   jaux,
 322      >                jaux, pcotrt,   jaux,
 323      >                jaux,   jaux,   jaux,
 324      >              ulsort, langue, codret )
 325 c
 326       endif
 327 c
 328 c 3.3. ==> les voisinages
 329 c
 330       if ( codret.eq.0 ) then
 331 c
 332 #ifdef _DEBUG_HOMARD_
 333       write (ulsort,texte(langue,3)) 'UTAD04', nompro
 334 #endif
 335       iaux = 15
 336       call utad04 ( iaux, nhvois,
 337      >                jaux,   jaux, pposif, pfacar,
 338      >              advotr, advoqu,
 339      >              lgpptr, lgppqu, adpptr, adppqu,
 340      >                jaux,   jaux,   jaux,
 341      >                jaux,   jaux,   jaux,
 342      >                jaux,   jaux,   jaux,
 343      >                jaux,   jaux,   jaux,
 344      >              ulsort, langue, codret )
 345 c
 346       endif
 347 c
 348       if ( codret.eq.0 ) then
 349 c
 350       iaux = 1
 351 #ifdef _DEBUG_HOMARD_
 352       write (ulsort,texte(langue,3)) 'UTVGAN', nompro
 353 #endif
 354       call utvgan ( nhvois, nhnoeu, nharet,
 355      >              iaux,
 356      >              ppovos, pvoiso,
 357      >              ulsort, langue, codret)
 358 c
 359       endif
 360 c
 361 c====
 362 c 4. Verification
 363 c====
 364 #ifdef _DEBUG_HOMARD_
 365       write (ulsort,*) '4. Verification ; codret = ', codret
 366 #endif
 367 c
 368 c 4.1. ==> Caracteristiques des groupes dans les familles MED
 369 ccc      call gmprsx (nompro,nhsupe//'.Tab5')
 370 ccc      call gmprsx (nompro,nhsupe//'.Tab6')
 371 ccc      call gmprsx (nompro,nhsupe//'.Tab9')
 372 ccc      call gmprsx (nompro,nhsups//'.Tab2')
 373 c
 374       if ( codret.eq.0 ) then
 375 c
 376       call gmliat ( nhsupe, 9, nbfmed, codre1 )
 377       call gmadoj ( nhsupe//'.Tab9', adnumf, iaux, codre2 )
 378       call gmadoj ( nhsupe//'.Tab5', adpoin, iaux, codre3 )
 379       call gmadoj ( nhsupe//'.Tab6', adtail, iaux, codre4 )
 380       call gmadoj ( nhsups//'.Tab2', adtabl, iaux, codre5 )
 381 c
 382       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 383       codret = max ( abs(codre0), codret,
 384      >               codre1, codre2, codre3, codre4, codre5 )
 385 c
 386       endif
 387 c
 388 c====
 389 c 5. Verification du maillage
 390 c====
 391 #ifdef _DEBUG_HOMARD_
 392       write (ulsort,*) '5. Verification ; codret = ', codret
 393 #endif
 394 c
 395       if ( codret.eq.0 ) then
 396 c
 397 #ifdef _DEBUG_HOMARD_
 398       write (ulsort,texte(langue,3)) 'MMAGVE', nompro
 399 #endif
 400       call mmagve ( imem(pfamte), imem(pcfate),
 401      >              nbfmed, imem(adnumf),
 402      >              imem(adpoin), imem(adtail), smem(adtabl),
 403      >              ulsort, langue, codret )
 404 c
 405       endif
 406 c
 407 c====
 408 c 6. Decompte des familles et des pentaedres a creer
 409 c====
 410 #ifdef _DEBUG_HOMARD_
 411       write (ulsort,*) '6. Decompte ; codret = ', codret
 412 #endif
 413 c
 414 c 6.1. ==> allocation des tableaux
 415 c
 416       if ( codret.eq.0 ) then
 417 c
 418       iaux = 4*nbtrto
 419       call gmalot ( ntrav1, 'entier  ', iaux, ptrav1, codre1 )
 420       iaux = 4*2*nbftet**2
 421 cgn      print *,iaux/4
 422       call gmalot ( ntrav2, 'entier  ', iaux, ptrav2, codre2 )
 423 c
 424       codre0 = min ( codre1, codre2 )
 425       codret = max ( abs(codre0), codret,
 426      >               codre1, codre2 )
 427 c
 428       endif
 429 c
 430 c 6.2. ==> Decompte associe aux joints simples
 431 c
 432       if ( codret.eq.0 ) then
 433       call gtdems (61)
 434 c
 435 #ifdef _DEBUG_HOMARD_
 436       write (ulsort,texte(langue,3)) 'MMAGR0', nompro
 437 #endif
 438       call mmagr0 ( imem(advotr),
 439      >              imem(pfamte), imem(pcfate),
 440      >              imem(ptrav1), imem(ptrav2),
 441      >              nbjois, nbpejs,
 442      >              ulsort, langue, codret )
 443       call gtfims (61)
 444 c
 445       endif
 446 c
 447       if ( codret.eq.0 ) then
 448 c
 449       if ( nbjois.eq.0 ) then
 450         goto 1800
 451       endif
 452 c
 453       endif
 454 c
 455 c 6.3. ==> Tableaux
 456 c
 457       if ( codret.eq.0 ) then
 458 c
 459       iaux = 4
 460       call gmmod ( ntrav1, ptrav1,
 461      >             iaux, iaux, nbtrto, nbpejs, codre0 )
 462 c
 463       codret = max ( abs(codre0), codret )
 464 c
 465       iaux = 8*3*nbpejs
 466       call gmalot ( ntra30, 'entier  ', iaux, ptra30, codre1 )
 467       iaux = 6*3*nbpejs
 468       call gmalot ( ntra40, 'entier  ', iaux, ptra40, codre2 )
 469       iaux = 2*3*nbpejs
 470       call gmalot ( ntra31, 'entier  ', iaux, ptra31, codre3 )
 471       iaux = 4*3*nbpejs
 472       call gmalot ( ntra41, 'entier  ', iaux, ptra41, codre4 )
 473       iaux = 4*3*nbpejs
 474       call gmalot ( ntrav3, 'entier  ', iaux, ptrav3, codre5 )
 475 c
 476       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 477       codret = max ( abs(codre0), codret,
 478      >               codre1, codre2, codre3, codre4, codre5 )
 479 cgn      call gmprsx ( nompro//' apres MMAGR0, ntrav1 :', ntrav1 )
 480 c
 481       endif
 482 c
 483 c 6.4. ==> Decompte des noeuds, aretes, quadrangles a creer/dupliquer
 484 c          et des familles deduites
 485 c
 486       if ( codret.eq.0 ) then
 487 c
 488 #ifdef _DEBUG_HOMARD_
 489       write (ulsort,texte(langue,3)) 'MMAG10', nompro
 490 #endif
 491       call mmag10 ( imem(psomar),
 492      >              imem(paretr),
 493      >              imem(ptrite), imem(pcotrt),
 494      >              nbjois, nbpejs, imem(ptrav1), imem(ptrav2),
 495      >              imem(ptra30), imem(ptra40),
 496      >              imem(ptra31), imem(ptra41),
 497      >              nbduno, nbduar, nbdutr,
 498      >              nbnotn, nbartn, nbtrtn, nbqutn,
 499      >              nbtetn, nbpetn, nbhetn,
 500      >              nbjoit, nbpejt, nbtrjt,
 501      >              nbjoiq, nbhejq, nbqujq,
 502      >              nbjp06, nbte06,
 503      >              nbjp09, nbpe09,
 504      >              nbjp12, nbhe12,
 505      >              nbvojm,
 506      >              imem(ptrav3),
 507      >              ntra51, ptra51, ntra52, ptra52,
 508      >              ntra53, ptra53,
 509      >              ulsort, langue, codret )
 510 c
 511 cgn           call gmprsx(nompro//' apres MMAG10, ntra51 :',ntra51)
 512 cgn           call gmprsx(nompro//' apres MMAG10, ntra52 :',ntra52)
 513 cgn           call gmprsx(nompro//' apres MMAG10, ntra53 :',ntra53)
 514 c
 515       endif
 516 c
 517       if ( codret.eq.0 ) then
 518 c
 519       nbjoto = nbjois + nbjoit + nbjoiq + nbjp06 + nbjp09 + nbjp12
 520 c
 521 #ifdef _DEBUG_HOMARD_
 522       write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno
 523       write (ulsort,texte(langue,7)) mess14(langue,3,1), nbduno
 524       write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar
 525       write (ulsort,texte(langue,8)) mess14(langue,3,2), nbdutr
 526       write (ulsort,texte(langue,7)) mess14(langue,3,2), nbtrjt
 527       write (ulsort,texte(langue,7)) mess14(langue,3,4), nbqutn
 528       write (ulsort,texte(langue,7)) mess14(langue,3,3), nbtetn
 529       write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpetn
 530       write (ulsort,texte(langue,7)) mess14(langue,3,6), nbhetn
 531 #endif
 532 c
 533       endif
 534 c
 535 c 6.5. ==> On raccourcit en fonction de ce qui a ete compte
 536 c
 537       if ( codret.eq.0 ) then
 538 c
 539       iaux = 4
 540       jaux = 2*nbftet**2
 541       call gmmod ( ntrav2, ptrav2,
 542      >             iaux, iaux, jaux, nbjoto, codre1 )
 543       iaux = 8
 544       jaux = 3*nbpejs
 545       call gmmod ( ntra30, ptra30,
 546      >             iaux, iaux, jaux, nbduno, codre2 )
 547       iaux = 6
 548       jaux = 3*nbpejs
 549       call gmmod ( ntra40, ptra40,
 550      >             iaux, iaux, jaux, nbduar, codre3 )
 551       iaux = 2
 552       jaux = 3*nbpejs
 553       call gmmod ( ntra31, ptra31,
 554      >             iaux, iaux, jaux, nbtrjt, codre4 )
 555       iaux = 4
 556       jaux = 3*nbpejs
 557       call gmmod ( ntra41, ptra41,
 558      >             iaux, iaux, jaux, nbvojm, codre5 )
 559 c
 560       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 561       codret = max ( abs(codre0), codret,
 562      >               codre1, codre2, codre3, codre4, codre5 )
 563 cgn      call gmprsx ( nompro, ntrav2 )
 564 cgn      call gmprsx ( nompro, ntrav2 )
 565 cgn      call gmprsx ( nompro, ntra31 )
 566 cgn      call gmprsx ( nompro, ntra41 )
 567 c
 568       endif
 569 c
 570       if ( codret.eq.0 ) then
 571 c
 572       call gmlboj ( ntrav3 , codret )
 573 c
 574       endif
 575 c
 576 c====
 577 c 7. Reallocation des tableaux du maillage
 578 c====
 579 #ifdef _DEBUG_HOMARD_
 580       write (ulsort,*) '7. Reallocation ; codret = ', codret
 581 #endif
 582 c
 583       if ( codret.eq.0 ) then
 584 c
 585       call gtdems (64)
 586 c
 587 #ifdef _DEBUG_HOMARD_
 588       write (ulsort,texte(langue,3)) 'MMAGR2', nompro
 589 #endif
 590       call mmagr2 ( nbnotn, nbartn, nbtrtn, nbqutn,
 591      >              nbtetn, nbpetn, nbhetn,
 592      >              nhnoeu, nharet, nhtria, nhquad,
 593      >              nhtetr, nhpent, nhhexa,
 594      >              phetno, pcoono, pareno, pderno,
 595      >              phetar, psomar, pfilar, pmerar,
 596      >              phettr, paretr, pfiltr, ppertr, pnivtr,
 597      >              phetqu, parequ, pfilqu, pperqu, pnivqu,
 598      >              phette, ptrite, pfilte, pperte, pcotrt,
 599      >              phetpe, pfacpe, pfilpe, pperpe, pcofap,
 600      >              phethe, pquahe, pfilhe, pperhe, pcoquh,
 601      >              pfamno, pfamar, pfamtr, pfamqu,
 602      >              pfamte, pfampe, pfamhe,
 603      >              ulsort, langue, codret )
 604 c
 605       call gtfims (64)
 606 c
 607       endif
 608 c
 609 c====
 610 c 8. Creation des noeuds, aretes, triangles, quadrangles, pentaedres,
 611 c    hexaedres
 612 c====
 613 #ifdef _DEBUG_HOMARD_
 614       write (ulsort,*) '8. Creation ; codret = ', codret
 615 #endif
 616 c
 617       if ( codret.eq.0 ) then
 618 c
 619 #ifdef _DEBUG_HOMARD_
 620       write (ulsort,texte(langue,3)) 'MMAG30', nompro
 621 #endif
 622 c
 623       call mmag30 ( nbduno, nbduar, nbdutr,
 624      >              nbpejs,
 625      >              nbpejt, nbtrjt, nbhejq, nbqujq,
 626      >              nbte06, nbpe09, nbhe12,
 627      >              nbvojm,
 628      >              nbjoto, nbjois, nbjoit, nbjoiq,
 629      >              nbjp06, nbjp09, nbjp12,
 630      >              imem(ptrav1), imem(ptrav2),
 631      >              imem(ptra30), imem(ptra40),
 632      >              imem(ptra41),
 633      >              imem(ptra51), imem(ptra52), imem(ptra53),
 634      >              rmem(pcoono), imem(phetno), imem(pareno),
 635      >              imem(psomar), imem(phetar),
 636      >              imem(pfilar), imem(pmerar),
 637      >              imem(paretr), imem(phettr),
 638      >              imem(pfiltr), imem(ppertr), imem(pnivtr),
 639      >              imem(parequ), imem(phetqu),
 640      >              imem(pfilqu), imem(pperqu), imem(pnivqu),
 641      >              imem(ptrite), imem(pcotrt),
 642      >              imem(phette), imem(pfilte), imem(pperte),
 643      >              imem(pfacpe), imem(pcofap),
 644      >              imem(phetpe), imem(pfilpe), imem(pperpe),
 645      >              imem(pquahe), imem(pcoquh),
 646      >              imem(phethe), imem(pfilhe), imem(pperhe),
 647      >              imem(pfamno), imem(pfamar),
 648      >              imem(pfamtr), imem(pfamqu),
 649      >              imem(pfamte), imem(pfampe), imem(pfamhe),
 650      >              ulsort, langue, codret )
 651 cgn           call gmprsx(nompro//' apres MMAG30, ntra52 :',ntra52)
 652 cgn        write (ulsort,*) mess14(langue,2,-1)
 653 cgn        call gmprsx(nompro,nhnoeu)
 654 cgn        call gmprsx(nompro,nhnoeu//'.Coor')
 655 cgn        call gmprsx(nompro,nhnoeu//'.AretSupp')
 656 cgn        call gmprsx(nompro,nhnoeu//'.Famille.EntiFamm')
 657 cgn        write (ulsort,*) mess14(langue,2,1)
 658 cgn        call gmprsx(nompro,nharet)
 659 cgn        call gmprsx(nompro,nharet//'.ConnDesc')
 660 cgn        call gmprsx(nompro,nharet//'.Famille.EntiFamm')
 661 cgn        write (ulsort,*) mess14(langue,2,2)
 662 cgn        call gmprsx(nompro,nhtria)
 663 cgn        call gmprsx(nompro,nhtria//'.ConnDesc')
 664 cgn        call gmprsx(nompro,nhtria//'.HistEtat')
 665 cgn        call gmprsx(nompro,nhtria//'.Niveau')
 666 cgn        call gmprsx(nompro,nhtria//'.Fille')
 667 cgn        call gmprsx(nompro,nhtria//'.Mere')
 668 cgn        call gmprsx(nompro,nhtria//'.Famille.EntiFamm')
 669 cgn        write (ulsort,*) mess14(langue,2,4)
 670 cgn        call gmprsx(nompro,nhquad)
 671 cgn        call gmprsx(nompro,nhquad//'.ConnDesc')
 672 cgn        call gmprsx(nompro,nhquad//'.HistEtat')
 673 cgn        call gmprsx(nompro,nhquad//'.Niveau')
 674 cgn        call gmprsx(nompro,nhquad//'.Fille')
 675 cgn        call gmprsx(nompro,nhquad//'.Mere')
 676 cgn        call gmprsx(nompro,nhquad//'.Famille')
 677 cgn        call gmprsx(nompro,nhquad//'.Famille.EntiFamm')
 678 cgn        write (ulsort,*) mess14(langue,2,3)
 679 cgn        call gmprsx(nompro,nhtetr)
 680 cgn        call gmprsx(nompro,nhtetr//'.ConnDesc')
 681 cgn        call gmprsx(nompro,nhtetr//'.HistEtat')
 682 cgn        call gmprsx(nompro,nhtetr//'.InfoSupp')
 683 cgn        call gmprsx(nompro,nhtetr//'.Fille')
 684 cgn        call gmprsx(nompro,nhtetr//'.Mere')
 685 cgn        call gmprsx(nompro,nhtetr//'.Famille')
 686 cgn        call gmprsx(nompro,nhtetr//'.Famille.EntiFamm')
 687 cgn        write (ulsort,*) mess14(langue,2,6)
 688 cgn        call gmprsx(nompro,nhhexa)
 689 cgn        call gmprsx(nompro,nhhexa//'.ConnDesc')
 690 cgn        call gmprsx(nompro,nhhexa//'.HistEtat')
 691 cgn        call gmprsx(nompro,nhhexa//'.InfoSupp')
 692 cgn        call gmprsx(nompro,nhhexa//'.Fille')
 693 cgn        call gmprsx(nompro,nhhexa//'.Mere')
 694 cgn        call gmprsx(nompro,nhhexa//'.Famille')
 695 cgn        call gmprsx(nompro,nhhexa//'.Famille.EntiFamm')
 696 cgn        write (ulsort,*) mess14(langue,2,7)
 697 cgn        call gmprsx(nompro,nhpent)
 698 cgn        call gmprsx(nompro,nhpent//'.ConnDesc')
 699 cgn        call gmprsx(nompro,nhpent//'.HistEtat')
 700 cgn        call gmprsx(nompro,nhpent//'.InfoSupp')
 701 cgn        call gmprsx(nompro,nhpent//'.Fille')
 702 cgn        call gmprsx(nompro,nhpent//'.Mere')
 703 cgn        call gmprsx(nompro,nhpent//'.Famille')
 704 cgn        call gmprsx(nompro,nhpent//'.Famille.EntiFamm')
 705 c
 706       endif
 707 c
 708 c====
 709 c 9. Modification eventuelle des coordonnees
 710 c      0 : aucune
 711 c      1 : mod_joint_qt_d1
 712 c      2 : mod_joint_qua2_d1
 713 c      3 : mod_joint_qua_d1
 714 c      4 : mod_joint_tri_d1
 715 c      5 : mod_joint_tri_d2
 716 c     -1 : automatique
 717 c====
 718 #ifdef _DEBUG_HOMARD_
 719       write (ulsort,*) '9. Modif coordonnees ; codret = ', codret
 720 #endif
 721 c
 722       if ( codret.eq.0 ) then
 723 c
 724       iaux = 0
 725       shrink = 0.95d0
 726 c
 727 #ifdef _DEBUG_HOMARD_
 728       write (ulsort,texte(langue,3)) 'MMAGCO', nompro
 729 #endif
 730       call mmagco ( iaux, shrink,
 731      >              rmem(pcoono),
 732      >              imem(psomar),
 733      >              nbduno, imem(ptra30),
 734      >              ulsort, langue, codret )
 735 c
 736       endif
 737 c
 738 c====
 739 c 10. Creation des familles
 740 c====
 741 #ifdef _DEBUG_HOMARD_
 742       write (ulsort,*) '10. Creation familles ; codret = ', codret
 743 #endif
 744 c
 745 c 10.1. ==> Les utilitaires
 746 c
 747       if ( codret.eq.0 ) then
 748 c
 749       call gmalot ( ntraw1, 'entier  ', nbjoto, ptraw1, codre1 )
 750       call gmalot ( ntraw2, 'entier  ', nbjoto, ptraw2, codre2 )
 751       call gmalot ( ntraw6, 'reel    ', nbjoto, ptraw6, codre3 )
 752 c
 753       codre0 = min ( codre1, codre2, codre3 )
 754       codret = max ( abs(codre0), codret,
 755      >               codre1, codre2, codre3 )
 756 c
 757       endif
 758 c
 759 c 10.2. ==> Creation effective
 760 c
 761       if ( codret.eq.0 ) then
 762 c
 763 #ifdef _DEBUG_HOMARD_
 764       write (ulsort,texte(langue,3)) 'MMAGF0', nompro
 765 #endif
 766       call mmagf0 ( nbjoto, nbjois, nbjoit, nbjoiq,
 767      >              nbjp06, nbjp09, nbjp12,
 768      >              nhnoeu, nhmapo, nharet, nhtria, nhquad,
 769      >              nhtetr, nhhexa, nhpyra, nhpent,
 770      >              nhsupe, nhsups,
 771      >              ulsort, langue, codret )
 772 cgn        write (ulsort,*) mess14(langue,2,2)
 773 cgn        call gmprsx(nompro,nhtria//'.Famille.Codes')
 774 cgn        write (ulsort,*) mess14(langue,2,4)
 775 cgn        call gmprsx(nompro,nhquad//'.Famille.Codes')
 776 cgn        write (ulsort,*) mess14(langue,2,3)
 777 cgn        call gmprsx(nompro,nhtetr//'.Famille.Codes')
 778 cgn        write (ulsort,*) mess14(langue,2,6)
 779 cgn        call gmprsx(nompro,nhhexa//'.Famille.Codes')
 780 cgn        write (ulsort,*) mess14(langue,2,7)
 781 cgn        call gmprsx(nompro,nhpent//'.Famille.Codes')
 782 c
 783       endif
 784 c
 785 c 10.3. ==> Reactualisation
 786 c
 787       if ( codret.eq.0 ) then
 788 c
 789       iaux = 259
 790 #ifdef _DEBUG_HOMARD_
 791       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 792 #endif
 793       call utad02 (   iaux, nhtetr,
 794      >                jaux,   jaux,  jaux, jaux,
 795      >              pfamte, pcfate,   jaux,
 796      >                jaux,   jaux,   jaux,
 797      >                jaux,   jaux,   jaux,
 798      >              ulsort, langue, codret )
 799 c
 800       endif
 801 c
 802 c====
 803 c 11. Reperage des grains
 804 c====
 805 #ifdef _DEBUG_HOMARD_
 806       write (ulsort,*) '11. Reperage des grains ; codret = ', codret
 807 #endif
 808 c 11.1. ==> Les utilitaires
 809 c
 810       if ( codret.eq.0 ) then
 811 c
 812       call gmalot ( ntrav3, 'entier  ', nbarto, ptrav3, codre1 )
 813       call gmalot ( ntrav4, 'entier  ', nbtrto, ptrav4, codre2 )
 814 c
 815       codre0 = min ( codre1, codre2 )
 816       codret = max ( abs(codre0), codret,
 817      >               codre1, codre2 )
 818 c
 819       endif
 820 c
 821 c 11.2. ==> Reperage des grains
 822 #ifdef _DEBUG_HOMARD_
 823       write (ulsort,*) '11.2. Grains ; codret = ', codret
 824 #endif
 825
 826       if ( codret.eq.0 ) then
 827 c
 828       call gtdems (76)
 829 c
 830 #ifdef _DEBUG_HOMARD_
 831       write (ulsort,texte(langue,3)) 'MMAGR4', nompro
 832 #endif
 833 c
 834       call mmagr4 ( nbte06, imem(ptrav3), imem(ptrav4),
 835      >              imem(paretr),
 836      >              imem(ptrite), imem(pcotrt),
 837      >              imem(pfamte), imem(pcfate),
 838      >              ulsort, langue, codret )
 839 cc              goto 5555
 840 c
 841 cgn      call gmprsx ( nompro, ntrav3 )
 842 cgn      call gmprsx ( nompro, ntrav4 )
 843 c
 844       call gtfims (76)
 845 c
 846       endif
 847 c
 848 c 11.3. ==> Repercussion dans les connectivites
 849 #ifdef _DEBUG_HOMARD_
 850       write (ulsort,*) '11.3. Repercussion ; codret = ', codret
 851 #endif
 852 c
 853       if ( codret.eq.0 ) then
 854 c
 855       call gtdems (77)
 856 c
 857 #ifdef _DEBUG_HOMARD_
 858       write (ulsort,texte(langue,3)) 'MMAGR5', nompro
 859 #endif
 860       call mmagr5 ( nbduno, nbduar, nbdutr, nbtrjt,
 861      >              nbpejs, nbjoto,
 862      >              imem(ptrav1), imem(ptrav2),
 863      >              imem(ptra30), imem(ptra40),
 864      >              imem(ptrav3), imem(ptrav4),
 865      >              imem(psomar),
 866      >              imem(paretr),
 867      >              imem(ptrite), imem(pfamte), imem(pcfate),
 868      >              imem(ppovos), imem(pvoiso),
 869      >              imem(pposif), imem(pfacar),
 870      >              imem(advotr),
 871      >              ulsort, langue, codret )
 872 c
 873       call gtfims (77)
 874 c
 875 cgn        write (ulsort,*) mess14(langue,2,-1)
 876 cgn        call gmprsx(nompro,nhnoeu)
 877 cgn        call gmprsx(nompro,nhnoeu//'.Coor')
 878 cgn        call gmprsx(nompro,nhnoeu//'.HistEtat')
 879 cgn        call gmprsx(nompro,nhnoeu//'.AretSupp')
 880 cgn        call gmprsx(nompro,nhnoeu//'.Famille.EntiFamm')
 881 cgn        write (ulsort,*) mess14(langue,2,1)
 882 cgn        call gmprsx(nompro,nharet)
 883 cgn        call gmprsx(nompro,nharet//'.ConnDesc')
 884 cgn        call gmprsx(nompro,nharet//'.Fille')
 885 cgn        call gmprsx(nompro,nharet//'.Mere')
 886 cgn        call gmprsx(nompro,nharet//'.Famille.EntiFamm')
 887 cgn        write (ulsort,*) mess14(langue,2,2)
 888 cgn        call gmprsx(nompro,nhtria)
 889 cgn        call gmprsx(nompro,nhtria//'.ConnDesc')
 890 cgn        call gmprsx(nompro,nhtria//'.HistEtat')
 891 cgn        call gmprsx(nompro,nhtria//'.Niveau')
 892 cgn        call gmprsx(nompro,nhtria//'.Fille')
 893 cgn        call gmprsx(nompro,nhtria//'.Mere')
 894 cgn        call gmprsx(nompro,nhtria//'.Famille.EntiFamm')
 895 cgn        write (ulsort,*) mess14(langue,2,4)
 896 cgn        call gmprsx(nompro,nhquad)
 897 cgn        call gmprsx(nompro,nhquad//'.ConnDesc')
 898 cgn        call gmprsx(nompro,nhquad//'.HistEtat')
 899 cgn        call gmprsx(nompro,nhquad//'.Niveau')
 900 cgn        call gmprsx(nompro,nhquad//'.Fille')
 901 cgn        call gmprsx(nompro,nhquad//'.Mere')
 902 cgn        call gmprsx(nompro,nhquad//'.Famille')
 903 cgn        call gmprsx(nompro,nhquad//'.Famille.EntiFamm')
 904 cgn        write (ulsort,*) mess14(langue,2,3)
 905 cgn        call gmprsx(nompro,nhtetr)
 906 cgn        call gmprsx(nompro,nhtetr//'.ConnDesc')
 907 cgn        call gmprsx(nompro,nhtetr//'.HistEtat')
 908 cgn        call gmprsx(nompro,nhtetr//'.InfoSupp')
 909 cgn        call gmprsx(nompro,nhtetr//'.Fille')
 910 cgn        call gmprsx(nompro,nhtetr//'.Mere')
 911 cgn        call gmprsx(nompro,nhtetr//'.Famille')
 912 cgn        call gmprsx(nompro,nhtetr//'.Famille.EntiFamm')
 913 cgn        write (ulsort,*) mess14(langue,2,7)
 914 cgn        call gmprsx(nompro,nhpent)
 915 cgn        call gmprsx(nompro,nhpent//'.ConnDesc')
 916 cgn        call gmprsx(nompro,nhpent//'.HistEtat')
 917 cgn        call gmprsx(nompro,nhpent//'.InfoSupp')
 918 cgn        call gmprsx(nompro,nhpent//'.Fille')
 919 cgn        call gmprsx(nompro,nhpent//'.Mere')
 920 cgn        call gmprsx(nompro,nhpent//'.Famille')
 921 cgn        call gmprsx(nompro,nhpent//'.Famille.EntiFamm')
 922       endif
 923 c
 924 c====
 925 c 12. Taille des joints
 926 c====
 927 #ifdef _DEBUG_HOMARD_
 928       write (ulsort,*) '12. Taille des joints ; codret = ', codret
 929 #endif
 930 c 12.1. ==> Les donnees
 931 c
 932       if ( codret.eq.0 ) then
 933 c
 934       iaux = 259
 935 #ifdef _DEBUG_HOMARD_
 936       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 937 #endif
 938       call utad02 (   iaux, nhtetr,
 939      >                jaux,   jaux,  jaux, jaux,
 940      >              pfamte, pcfate,   jaux,
 941      >                jaux,   jaux,   jaux,
 942      >                jaux,   jaux,   jaux,
 943      >              ulsort, langue, codret )
 944 c
 945       endif
 946 c
 947       if ( codret.eq.0 ) then
 948 c
 949       iaux = 259
 950 #ifdef _DEBUG_HOMARD_
 951       write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 952 #endif
 953       call utad02 (   iaux, nhpent,
 954      >                jaux,   jaux,  jaux, jaux,
 955      >              pfampe, pcfape,   jaux,
 956      >                jaux,   jaux,   jaux,
 957      >                jaux,   jaux,   jaux,
 958      >              ulsort, langue, codret )
 959 c
 960       endif
 961 c
 962       if ( codret.eq.0 ) then
 963 c
 964       iaux = 259
 965 #ifdef _DEBUG_HOMARD_
 966       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 967 #endif
 968       call utad02 (   iaux, nhhexa,
 969      >                jaux,   jaux,  jaux, jaux,
 970      >              pfamhe, pcfahe,   jaux,
 971      >                jaux,   jaux,   jaux,
 972      >                jaux,   jaux,   jaux,
 973      >              ulsort, langue, codret )
 974 c
 975       endif
 976 c
 977       if ( codret.eq.0 ) then
 978 c
 979       call gmliat ( nhsupe, 6, iaux, codre1 )
 980       call gmliat ( nhsupe, 9, nbfmed, codre2 )
 981       call gmadoj ( nhsupe//'.Tab9', adnumf, iaux, codre3 )
 982       call gmadoj ( nhsupe//'.Tab5', adpoin, iaux, codre4 )
 983       call gmadoj ( nhsupe//'.Tab6', adtail, iaux, codre5 )
 984       call gmadoj ( nhsups//'.Tab2', adtabl, iaux, codre6 )
 985 c
 986       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 987      >               codre6 )
 988       codret = max ( abs(codre0), codret,
 989      >               codre1, codre2, codre3, codre4, codre5,
 990      >               codre6 )
 991 c
 992        ngrouc = iaux/10
 993 c
 994       endif
 995 c
 996       if ( codret.eq.0 ) then
 997 c
 998       iaux = 10*ngrouc
 999       call gmalot ( ntra17, 'chaine  ', iaux, ptra17, codre1 )
1000       iaux = ngrouc + nbfmed
1001       call gmalot ( ntra18, 'entier  ', iaux, ptra18, codre2 )
1002 c
1003       codre0 = min ( codre1, codre2 )
1004       codret = max ( abs(codre0), codret,
1005      >               codre1, codre2 )
1006 c
1007       endif
1008 c
1009 c 12.2. ==> Liste des noms des groupes
1010 c
1011       if ( codret.eq.0 ) then
1012 c
1013 #ifdef _DEBUG_HOMARD_
1014         write (ulsort,texte(langue,3)) 'UTFMLG', nompro
1015 #endif
1016       call utfmlg ( nbfmed, ngrouc,
1017      >              imem(adpoin), imem(adtail), smem(adtabl),
1018      >              nbgrfm, smem(ptra17), imem(ptra18),
1019      >              ulsort, langue, codret )
1020 c
1021 #ifdef _DEBUG_HOMARD_
1022       write(ulsort,90002) 'nbgrfm', nbgrfm
1023       call gmprsx ( nompro, ntra17 )
1024       call gmprsx ( nompro, ntra18 )
1025 #endif
1026 c
1027       endif
1028 c
1029 c 12.3. ==> Affichage
1030 c
1031       if ( codret.eq.0 ) then
1032 c
1033 #ifdef _DEBUG_HOMARD_
1034       write (ulsort,texte(langue,3)) 'MMAG40', nompro
1035 #endif
1036 c
1037       call mmag40 ( nbpejs, nbpejt, nbhejq,
1038      >              nbvojm, nbjoto,
1039      >              nbjois, nbjoit, nbjoiq,
1040      >              imem(ptrav1), imem(ptra41),
1041      >              rmem(pcoono), imem(psomar), imem(paretr),
1042      >              imem(pfamhe), imem(pcfahe),
1043      >              imem(pfampe), imem(pcfape),
1044      >              nbfmed, imem(adnumf),
1045      >              imem(adpoin), imem(adtail), smem(adtabl),
1046      >              nbgrfm, smem(ptra17), imem(ptra18),
1047      >              imem(ptraw1), rmem(ptraw6),
1048      >              imem(ptraw2),
1049      >              nuroul,
1050      >              ulsort, langue, codret )
1051 c
1052       endif
1053 c
1054 c====
1055 c 13. Suppression des entites dupliquees
1056 c====
1057 c 13.1. ==> Tableaux de travail
1058 #ifdef _DEBUG_HOMARD_
1059       write (ulsort,*) '13.1. Tab de travail ; codret = ', codret
1060 #endif
1061       call gtdems (78)
1062 c
1063       if ( codret.eq.0 ) then
1064       call gmlboj ( ntrav2 , codret )
1065       endif
1066 c
1067       if ( codret.eq.0 ) then
1068       call gmalot ( ntrav2, 'entier  ', nbnoto, ptrav2, codret )
1069       endif
1070 c
1071       if ( codret.eq.0 ) then
1072 c
1073       call gmalot ( ntraat, 'entier  ', nbtrto, ptraat, codre1 )
1074       iaux = nbtrto+1
1075       call gmalot ( ntrant, 'entier  ', iaux, ptrant, codre2 )
1076       call gmalot ( ntraaa, 'entier  ', nbarto, ptraaa, codre3 )
1077       iaux = nbarto+1
1078       call gmalot ( ntrana, 'entier  ', iaux, ptrana, codre4 )
1079       call gmalot ( ntraan, 'entier  ', nbnoto, ptraan, codre5 )
1080       iaux = nbnoto+1
1081       call gmalot ( ntrann, 'entier  ', iaux, ptrann, codre6 )
1082 c
1083       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
1084      >               codre6 )
1085       codret = max ( abs(codre0), codret,
1086      >               codre1, codre2, codre3, codre4, codre5,
1087      >               codre6 )
1088 c
1089       endif
1090 c
1091 c 13.2. ==> Nettoyage de la structure des voisins
1092 #ifdef _DEBUG_HOMARD_
1093       write (ulsort,*) '13.2. Voisins ; codret = ', codret
1094 #endif
1095 c
1096       if ( codret.eq.0 ) then
1097       call gmlboj ( nhvois, codret )
1098       endif
1099       if ( codret.eq.0 ) then
1100       call gmaloj ( nomail//'.Voisins' , ' ', 0, iaux, codret )
1101       endif
1102       if ( codret.eq.0 ) then
1103       call gmnomc ( nomail//'.Voisins' , nhvois, codret )
1104       endif
1105 c
1106 c 13.3. ==> Suppression effective
1107 #ifdef _DEBUG_HOMARD_
1108       write (ulsort,*) '13.3. suppression ; codret = ', codret
1109 #endif
1110 c
1111       if ( codret.eq.0 ) then
1112 c
1113 #ifdef _DEBUG_HOMARD_
1114       write (ulsort,texte(langue,3)) 'MMAGR6', nompro
1115 #endif
1116       call mmagr6 ( nbduno, nbduar, nbdutr,
1117      >              imem(ptrav1), imem(ptra30), imem(ptra40),
1118      >              imem(ptrav2), imem(ptrav3), imem(ptrav4),
1119      >              rmem(pcoono), imem(pfamno),
1120      >              imem(psomar), imem(pfamar),
1121      >              imem(paretr), imem(pfamtr),
1122      >              imem(parequ),
1123      >              imem(ptrite), imem(pfacpe),
1124      >              imem(ptraat), imem(ptrant),
1125      >              imem(ptraaa), imem(ptrana),
1126      >              imem(ptraan), imem(ptrann),
1127      >              nbtrtn, nbartn, nbnotn,
1128      >              ulsort, langue, codret )
1129 c
1130       endif
1131       call gtfims (78)
1132 c
1133 c====
1134 c 14. Reallocation des tableaux du maillage
1135 c====
1136 #ifdef _DEBUG_HOMARD_
1137       write (ulsort,*) '14. Reallocation ; codret = ', codret
1138 #endif
1139       call gtdems (64)
1140 c
1141 c 14.1. ==> Reallocation
1142 #ifdef _DEBUG_HOMARD_
1143       write (ulsort,texte(langue,3)) 'MMAGR2', nompro
1144 #endif
1145 c
1146       if ( codret.eq.0 ) then
1147 c
1148       nbqutn = -1
1149       nbpetn = -1
1150       call mmagr2 ( nbnotn, nbartn, nbtrtn, nbqutn,
1151      >              nbtetn, nbpetn, nbhetn,
1152      >              nhnoeu, nharet, nhtria, nhquad,
1153      >              nhtetr, nhpent, nhhexa,
1154      >              phetno, pcoono, pareno, pderno,
1155      >              phetar, psomar, pfilar, pmerar,
1156      >              phettr, paretr, pfiltr, ppertr, pnivtr,
1157      >              phetqu, parequ, pfilqu, pperqu, pnivqu,
1158      >              phette, ptrite, pfilte, pperte, pcotrt,
1159      >              phetpe, pfacpe, pfilpe, pperpe, pcofap,
1160      >              phethe, pquahe, pfilhe, pperhe, pcoquh,
1161      >              pfamno, pfamar, pfamtr, pfamqu,
1162      >              pfamte, pfampe, pfamhe,
1163      >              ulsort, langue, codret )
1164 c
1165       endif
1166 c
1167 c 14.2. ==> Mise a jour
1168 #ifdef _DEBUG_HOMARD_
1169       write (ulsort,*) '14.2. Mise a jour ; codret = ', codret
1170 #endif
1171 c
1172       if ( codret.eq.0 ) then
1173 c
1174       nbnoma = nbnoto
1175       nbnop1 = nbnoto
1176       numap1 = nbnoto
1177       nbarac = nbarto
1178       nbarma = nbarto
1179       nbarpe = nbarto
1180       nbtrac = nbtrto
1181       nbtrma = nbtrto
1182       nbtrpe = nbtrto
1183       nbquac = nbquto
1184       nbquma = nbquto
1185       nbqupe = nbquto
1186       nbteac = nbteto
1187       nbtema = nbteto
1188       nbtepe = nbteto
1189       nbpeac = nbpeto
1190       nbpema = nbpeto
1191       nbpepe = nbpeto
1192       nbheac = nbheto
1193       nbhema = nbheto
1194       nbhepe = nbheto
1195 c
1196       endif
1197       call gtfims (64)
1198 cgn        write (ulsort,*) mess14(langue,2,-1)
1199 cgn        call gmprsx(nompro,nhnoeu)
1200 cgn        call gmprsx(nompro,nhnoeu//'.Coor')
1201 cgn        call gmprsx(nompro,nhnoeu//'.HistEtat')
1202 cgn        call gmprsx(nompro,nhnoeu//'.AretSupp')
1203 cgn        call gmprsx(nompro,nhnoeu//'.Famille.EntiFamm')
1204 cgn        write (ulsort,*) mess14(langue,2,1)
1205 cgn        call gmprsx(nompro,nharet)
1206 cgn        call gmprsx(nompro,nharet//'.ConnDesc')
1207 cgn        call gmprsx(nompro,nharet//'.Fille')
1208 cgn        call gmprsx(nompro,nharet//'.Mere')
1209 cgn        call gmprsx(nompro,nharet//'.Famille.EntiFamm')
1210 cgn        write (ulsort,*) mess14(langue,2,2)
1211 cgn        call gmprsx(nompro,nhtria)
1212 cgn        call gmprsx(nompro,nhtria//'.ConnDesc')
1213 cgn        call gmprsx(nompro,nhtria//'.HistEtat')
1214 cgn        call gmprsx(nompro,nhtria//'.Niveau')
1215 cgn        call gmprsx(nompro,nhtria//'.Fille')
1216 cgn        call gmprsx(nompro,nhtria//'.Mere')
1217 cgn        call gmprsx(nompro,nhtria//'.Famille.EntiFamm')
1218 cgn        write (ulsort,*) mess14(langue,2,4)
1219 cgn        call gmprsx(nompro,nhquad)
1220 cgn        call gmprsx(nompro,nhquad//'.ConnDesc')
1221 cgn        call gmprsx(nompro,nhquad//'.HistEtat')
1222 cgn        call gmprsx(nompro,nhquad//'.Niveau')
1223 cgn        call gmprsx(nompro,nhquad//'.Fille')
1224 cgn        call gmprsx(nompro,nhquad//'.Mere')
1225 cgn        call gmprsx(nompro,nhquad//'.Famille')
1226 cgn        call gmprsx(nompro,nhquad//'.Famille.EntiFamm')
1227 cgn        write (ulsort,*) mess14(langue,2,3)
1228 cgn        call gmprsx(nompro,nhtetr)
1229 cgn        call gmprsx(nompro,nhtetr//'.ConnDesc')
1230 cgn        call gmprsx(nompro,nhtetr//'.HistEtat')
1231 cgn        call gmprsx(nompro,nhtetr//'.InfoSupp')
1232 cgn        call gmprsx(nompro,nhtetr//'.Fille')
1233 cgn        call gmprsx(nompro,nhtetr//'.Mere')
1234 cgn        call gmprsx(nompro,nhtetr//'.Famille')
1235 cgn        call gmprsx(nompro,nhtetr//'.Famille.EntiFamm')
1236 cgn        write (ulsort,*) mess14(langue,2,7)
1237 cgn        call gmprsx(nompro,nhpent)
1238 cgn        call gmprsx(nompro,nhpent//'.ConnDesc')
1239 cgn        call gmprsx(nompro,nhpent//'.HistEtat')
1240 cgn        call gmprsx(nompro,nhpent//'.InfoSupp')
1241 cgn        call gmprsx(nompro,nhpent//'.Fille')
1242 cgn        call gmprsx(nompro,nhpent//'.Mere')
1243 cgn        call gmprsx(nompro,nhpent//'.Famille')
1244 cgn        call gmprsx(nompro,nhpent//'.Famille.EntiFamm')
1245 c
1246 c====
1247 c 15. Conversion eventuelle en degre 2
1248 c====
1249 #ifdef _DEBUG_HOMARD_
1250       write (ulsort,*) '15. Conversion degre 2 ; codret = ', codret
1251 #endif
1252 c
1253       if ( degre0.eq.2 ) then
1254 c
1255       call gtdems (79)
1256 c
1257         if ( codret.eq.0 ) then
1258 c
1259 #ifdef _DEBUG_HOMARD_
1260       write (ulsort,texte(langue,3)) 'MMDEG0', nompro
1261 #endif
1262 c
1263         call mmdeg0 ( nomail,
1264      >                ulsort, langue, codret )
1265 c
1266         endif
1267 c
1268         if ( codret.eq.0 ) then
1269 c
1270 #ifdef _DEBUG_HOMARD_
1271       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
1272 #endif
1273 c
1274         call utnomh ( nomail,
1275      >                sdim,   mdim,
1276      >               degre, maconf, homolo, hierar,
1277      >              rafdef, nbmane, typcca, typsfr, maextr,
1278      >              mailet,
1279      >                norenu,
1280      >                nhnoeu, nhmapo, nharet,
1281      >                nhtria, nhquad,
1282      >                nhtetr, nhhexa, nhpyra, nhpent,
1283      >                nhelig,
1284      >                nhvois, nhsupe, nhsups,
1285      >                ulsort, langue, codret)
1286 c
1287         endif
1288 c
1289       call gtfims (79)
1290 c
1291       endif
1292 c
1293 c====
1294 c 16. mise a jour des grandeurs caracteristiques
1295 c====
1296 #ifdef _DEBUG_HOMARD_
1297       write (ulsort,*) '16. mise a jour ; codret = ', codret
1298 #endif
1299 c
1300 c 16.1. ==> nbmane : nombre maximal de noeuds par element
1301 c
1302       if ( codret.eq.0 ) then
1303 c
1304       if ( degre.eq.1 ) then
1305         if ( nbjoiq.eq.0 ) then
1306           nbmane = 6
1307         else
1308           nbmane = 8
1309         endif
1310       else
1311         if ( nbjoiq.eq.0 ) then
1312           nbmane = 15
1313         else
1314           nbmane = 20
1315         endif
1316       endif
1317 c
1318 cgn      print *, nbmane
1319       call gmecat ( nomail, 8, nbmane , codret )
1320 c
1321       endif
1322 c
1323 c 16.2. ==> determination des voisinages
1324 #ifdef _DEBUG_HOMARD_
1325       write (ulsort,*) '15.2. ; codret = ', codret
1326 #endif
1327 c
1328       if ( codret.eq.0 ) then
1329 c
1330       voarno = 1
1331       vofaar = 1
1332       vovoar = 0
1333       vovofa = 1
1334 c
1335 #ifdef _DEBUG_HOMARD_
1336       write (ulsort,texte(langue,3)) 'UTVOIS', nompro
1337 #endif
1338       call utvois ( nomail, nhvois,
1339      >              voarno, vofaar, vovoar, vovofa,
1340      >              ppovos, pvoiso,
1341      >              nbfaar, pposif, pfacar,
1342      >              ulsort, langue, codret )
1343 c
1344       endif
1345 cgn      call gmprsx (nompro, nhvois )
1346 cgn      call gmprsx (nompro, nhvois//'.0D/1D' )
1347 cgn      call gmprsx (nompro, nhvois//'.0D/1D.Pointeur' )
1348 cgn      call gmprsx (nompro, nhvois//'.0D/1D.Table' )
1349 cgn      call gmprsx (nompro, nhvois//'.1D/2D' )
1350 cgn      call gmprsx (nompro, nhvois//'.Vol/Tri' )
1351 cgn      call gmprsx (nompro, nhvois//'.Vol/Qua' )
1352 cgn      call gmprsx (nompro, nhvois//'.PyPe/Tri' )
1353 cgn      call gmprsx (nompro, nhvois//'.PyPe/Qua' )
1354 c
1355 c====
1356 c 17. Menage
1357 c====
1358 #ifdef _DEBUG_HOMARD_
1359       write (ulsort,*) '17. Menage ; codret = ', codret
1360 #endif
1361 c
1362       if ( codret.eq.0 ) then
1363 c
1364       call gmlboj ( ntrav1 , codre1 )
1365       call gmlboj ( ntrav2 , codre2 )
1366       call gmlboj ( ntrav3 , codre3 )
1367       call gmlboj ( ntrav4 , codre4 )
1368 c
1369       codre0 = min ( codre1, codre2, codre3, codre4 )
1370       codret = max ( abs(codre0), codret,
1371      >               codre1, codre2, codre3, codre4 )
1372 c
1373       call gmlboj ( ntraw1 , codre1 )
1374       call gmlboj ( ntraw2 , codre2 )
1375       call gmlboj ( ntraw6 , codre3 )
1376 c
1377       codre0 = min ( codre1, codre2, codre3 )
1378       codret = max ( abs(codre0), codret,
1379      >               codre1, codre2, codre3 )
1380 cgn      print *,codre1, codre2, codre3
1381 c
1382       call gmlboj ( ntra30 , codre1 )
1383       call gmlboj ( ntra40 , codre2 )
1384       call gmlboj ( ntra31 , codre3 )
1385       call gmlboj ( ntra41 , codre4 )
1386 c
1387       codre0 = min ( codre1, codre2, codre3, codre4 )
1388       codret = max ( abs(codre0), codret,
1389      >               codre1, codre2, codre3, codre4 )
1390 cgn      print *,codre1, codre2, codre3, codre4
1391 c
1392       call gmlboj ( ntra51 , codre1 )
1393       call gmlboj ( ntra52 , codre2 )
1394       call gmlboj ( ntra53 , codre3 )
1395 c
1396       codre0 = min ( codre1, codre2, codre3 )
1397       codret = max ( abs(codre0), codret,
1398      >               codre1, codre2, codre3 )
1399 cgn      print *,codre1, codre2
1400 c
1401       call gmlboj ( ntraat , codre1 )
1402       call gmlboj ( ntrant , codre2 )
1403       call gmlboj ( ntraaa , codre3 )
1404       call gmlboj ( ntrana , codre4 )
1405       call gmlboj ( ntraan , codre5 )
1406       call gmlboj ( ntrann , codre6 )
1407 cgn      print *,codre1, codre2, codre3, codre4, codre5,
1408 cgn     >               codre6
1409 c
1410       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
1411      >               codre6 )
1412       codret = max ( abs(codre0), codret,
1413      >               codre1, codre2, codre3, codre4, codre5,
1414      >               codre6 )
1415 c
1416       call gmlboj ( ntra17, codre1 )
1417       call gmlboj ( ntra18, codre2 )
1418 c
1419       codre0 = min ( codre1, codre2 )
1420       codret = max ( abs(codre0), codret,
1421      >               codre1, codre2 )
1422 c
1423       endif
1424 c
1425 c====
1426 c 18. la fin
1427 c====
1428 c
1429  1800 continue
1430 c
1431 c 18.1. ==> erreurs
1432 c
1433       if ( codret.ne.0 ) then
1434 c
1435 #include "envex2.h"
1436 c
1437       write (ulsort,texte(langue,1)) 'Sortie', nompro
1438       write (ulsort,texte(langue,2)) codret
1439 c
1440       endif
1441 c
1442 c 18.2. ==> fin des mesures de temps de la section
1443 c
1444       call gtfims (nrosec)
1445 c
1446 #ifdef _DEBUG_HOMARD_
1447       write (ulsort,texte(langue,1)) 'Sortie', nompro
1448       call dmflsh (iaux)
1449 #endif
1450 c
1451       end