src/tool/AP_Conversion/pcmaco.F

   1       subroutine pcmaco ( modhom,
   2      >                    nocmap, nomail, nomamd, lnomam,
   3      >                    nospec,
   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    aPres adaptation - Conversion de MAillage - COnnectivite
  26 c     -                 -             --         --
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . modhom . e   .    1   . mode de fonctionnement de homard           .
  32 c .        .     .        .  1 : homard pur                            .
  33 c .        .     .        .  2 : information                           .
  34 c .        .     .        .  3 : modification de maillage sans adaptati.
  35 c .        .     .        .  4 : interpolation de la solution          .
  36 c . nocmap .   s . char8  . nom de l'objet maillage de calcul iter. n+1.
  37 c . nomail . e   . char8  . nom de l'objet maillage homard iter. n+1   .
  38 c . nomamd . e   . char64 . nom med du maillage iteration n+1          .
  39 c . lnomam . e   .   1    . longueur de nomamd                         .
  40 c . nospec .   s . char8  . nom de l'objet memorisant les specificites .
  41 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  42 c . langue . e   .    1   . langue des messages                        .
  43 c .        .     .        . 1 : francais, 2 : anglais                  .
  44 c . codret . es  .    1   . code de retour des modules                 .
  45 c .        .     .        . 0 : pas de probleme                        .
  46 c .        .     .        . 1 : probleme                               .
  47 c ______________________________________________________________________
  48 c
  49 c====
  50 c 0. declarations et dimensionnement
  51 c====
  52 c
  53 c 0.1. ==> generalites
  54 c
  55       implicit none
  56       save
  57 c
  58       character*6 nompro
  59       parameter ( nompro = 'PCMACO' )
  60 c
  61 #include "nblang.h"
  62 c
  63 c 0.2. ==> communs
  64 c
  65 #include "envex1.h"
  66 c
  67 #include "gmenti.h"
  68 #include "gmreel.h"
  69 #include "gmstri.h"
  70 c
  71 #include "envca1.h"
  72 #include "envada.h"
  73 c
  74 #include "nbutil.h"
  75 #include "nombno.h"
  76 #include "nombar.h"
  77 #include "nombmp.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 "nombsr.h"
  85 #include "nbfami.h"
  86 #include "dicfen.h"
  87 c
  88 #include "impr02.h"
  89 c
  90 c 0.3. ==> arguments
  91 c
  92       integer modhom
  93       integer lnomam
  94 c
  95       character*8 nocmap, nomail
  96       character*64 nomamd
  97       character*8 nospec
  98 c
  99       integer ulsort, langue, codret
 100 c
 101 c 0.4. ==> variables locales
 102 c
 103       integer pcoono, adcocs, phetno, pancno
 104       integer pnoemp, phetmp
 105       integer psomar, phetar, pfilar, pmerar, pnp2ar
 106       integer paretr, phettr, ppertr, pfiltr, pnivtr, adnmtr
 107       integer parequ, phetqu, pperqu, pfilqu, pnivqu, adnmqu
 108       integer ptrite, pcotrt, parete, phette
 109       integer pquahe, pcoquh, parehe, phethe, adnmhe
 110       integer advotr, adpptr
 111       integer advoqu, adppqu
 112       integer pfacpy, pcofay, parepy, phetpy
 113       integer pfacpe, pcofap, parepe, phetpe
 114       integer ppovos, pvoiso
 115       integer pposif, pfacar
 116       integer pfamno, pcfano
 117       integer pfammp, pcfamp
 118       integer pfamar, pcfaar
 119       integer pfamtr, pcfatr
 120       integer pfamqu, pcfaqu
 121       integer pfamte, pcfate
 122       integer pfamhe, pcfahe
 123       integer pfampy, pcfapy
 124       integer pfampe, pcfape
 125       integer hfmdel, hnoeel
 126       integer dimcst
 127 c
 128       integer adnbrp
 129       integer adnocp, adnohp
 130       integer admpcp, admphp
 131       integer adarcp, adarhp
 132       integer adtrcp, adtrhp
 133       integer adtecp, adtehp
 134       integer adqucp, adquhp
 135       integer adhecp, adhehp
 136       integer adpycp, adpyhp
 137       integer adpecp, adpehp
 138 c
 139       integer adnomb
 140       integer pfamen, pfamee, pnoeel, ptypel, pcoonc
 141       integer pinfpt, pinftb
 142       integer nparrc, nptrrc, npqurc
 143       integer npterc, npherc, npperc, nppyrc
 144       integer adarrc, adtrrc, adqurc
 145       integer adterc, adherc, adperc, adpyrc
 146       integer lgtrc1, lgtrc2, lgtrc3
 147       integer lgtrc4, lgtrc5, lgtrc6, lgtrc7
 148       integer ptrav4
 149       integer nbanci, nbenrc, numead
 150       integer adarra, adarrb
 151       integer adtrra
 152       integer adqura
 153 c
 154       integer iaux,  jaux, kaux, laux
 155       integer codre1, codre2, codre3, codre4
 156       integer codre0
 157       integer nbele0, un
 158       integer nonexm
 159       integer nbpqt
 160 c
 161       character*8 norenu
 162       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 163       character*8 nhtetr, nhhexa, nhpyra, nhpent
 164       character*8 nhelig
 165       character*8 nhvois, nhsupe, nhsups
 166       character*8 nhqufa
 167       character*8 ncinfo, ncnoeu, nccono, nccode
 168       character*8 nccoex, ncfami
 169       character*8 ncequi, ncfron, ncnomb
 170       character*8 ntrav1, ntrav2, ntrav3, ntrav4
 171 c
 172       character*8 heurus
 173       character*9 dateus
 174       character*32 saux32
 175 c
 176       logical noeord
 177       logical existe
 178       logical deraff
 179       logical cforme
 180 c
 181       integer nbmess
 182       parameter ( nbmess = 30 )
 183       character*80 texte(nblang,nbmess)
 184 c
 185 cmdc ---------------- MAILLES DOUBLES DEBUT --------------
 186 cmd      character*80 nomfic
 187 cmd      integer nbele1, nbtenw
 188 cmd      logical maildb
 189 cmd      integer adpoin, adtail, adtabl
 190 cmd      integer adnumf
 191 cmd      integer ptrav5
 192 cmd      character*8 ntrav5
 193 cmdc ---------------- MAILLES DOUBLES FIN ----------------
 194 c
 195 c 0.5. ==> initialisations
 196 c ______________________________________________________________________
 197 c
 198 c====
 199 c 1. messages
 200 c====
 201 c
 202 #include "impr01.h"
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,texte(langue,1)) 'Entree', nompro
 206       call dmflsh (iaux)
 207 #endif
 208 c
 209       texte(1,7) = '(5x,''Conversion HOMARD ----> '',a18,/)'
 210       texte(1,8) =
 211      > '(5x,''Caracteristiques du maillage apres conversion :'',/)'
 212 c
 213       texte(2,7) = '(5x,''Conversion HOMARD ----> '',a18,/)'
 214       texte(2,8) =
 215      > '(5x,''Characteristics of the mesh after conversion :'',/)'
 216 c
 217 #include "impr03.h"
 218 c
 219 #include "impr06.h"
 220 c
 221       un = 1
 222 c
 223 c====
 224 c 2. recuperation des pointeurs
 225 c====
 226 c
 227 #ifdef _DEBUG_HOMARD_
 228       write (ulsort,90002) '2. recuperation donnees ; codret', codret
 229 #endif
 230 c
 231 c 2.1. ==> on alloue la future renumerotation
 232 c          remarque : on la supprime si elle existait ; cela arrive
 233 c                     dans les cas de modifications de maillage
 234 c
 235       if ( codret.eq.0 ) then
 236 c
 237       call gmobal ( nomail//'.RenuMail', codre0 )
 238 c
 239       if ( codre0.eq.1 ) then
 240         call gmlboj ( nomail//'.RenuMail', codret )
 241       elseif ( codre0.ne.0 ) then
 242         codret = 2
 243       endif
 244 c
 245       endif
 246 c
 247       if ( codret.eq.0 ) then
 248 c
 249       call gmaloj ( nomail//'.RenuMail', ' ', 0, iaux, codret )
 250 c
 251       endif
 252 c
 253 c 2.2. ==> structure generale
 254 c
 255 #ifdef _DEBUG_HOMARD_
 256       write (ulsort,90002) '2.2. ==> structure gale ; codret', codret
 257       call dmflsh (iaux)
 258 #endif
 259 c
 260       if ( codret.eq.0 ) then
 261 c
 262 #ifdef _DEBUG_HOMARD_
 263       call gmprsx (nompro,nomail)
 264       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 265 #endif
 266       call utnomh ( nomail,
 267      >                sdim,   mdim,
 268      >               degre, maconf, homolo, hierar,
 269      >              rafdef, nbmane, typcca, typsfr, maextr,
 270      >              mailet,
 271      >              norenu,
 272      >              nhnoeu, nhmapo, nharet,
 273      >              nhtria, nhquad,
 274      >              nhtetr, nhhexa, nhpyra, nhpent,
 275      >              nhelig,
 276      >              nhvois, nhsupe, nhsups,
 277      >              ulsort, langue, codret)
 278 c
 279       endif
 280 c
 281       if ( codret.eq.0 ) then
 282 #include "mslve4.h"
 283       endif
 284 c
 285       if ( codret.eq.0 ) then
 286 c
 287       if ( ( rafdef.eq.3 .or. rafdef.eq.4 ) .and. nbiter .gt.1 ) then
 288         deraff = .true.
 289       else
 290         deraff = .false.
 291       endif
 292 c
 293       if ( maconf.eq.-1 .or. maconf.eq.0 ) then
 294         cforme = .true.
 295       else
 296         cforme = .false.
 297       endif
 298 #ifdef _DEBUG_HOMARD_
 299       write (ulsort,99001) 'cforme', cforme
 300 #endif
 301 c
 302       nonexm = 1
 303       if ( ( typcca.eq.36 ) .or. ( typcca.eq.56 ) ) then
 304         nonexm = nonexm*2
 305       endif
 306 #ifdef _DEBUG_HOMARD_
 307       write (ulsort,90002) 'nonexm', nonexm
 308 #endif
 309 c
 310       endif
 311 c
 312 c 2.3. ==> tableaux
 313 c
 314 #ifdef _DEBUG_HOMARD_
 315       write (ulsort,90002) '2.3. ==> tableaux ; codret', codret
 316       call dmflsh(iaux)
 317 #endif
 318 c
 319       if ( codret.eq.0 ) then
 320 c
 321       iaux = 42
 322 #ifdef _DEBUG_HOMARD_
 323       write (ulsort,texte(langue,3)) 'UTAD01', nompro
 324 #endif
 325       call utad01 ( iaux, nhnoeu,
 326      >              phetno,
 327      >              pfamno, pcfano,   jaux,
 328      >              pcoono,   jaux,   jaux,   jaux,
 329      >              ulsort, langue, codret )
 330 c
 331       if ( deraff ) then
 332         call gmadoj ( nhnoeu//'.Deraffin', pancno, iaux, codre1 )
 333         call gmalot ( ntrav4, 'entier', nbnoto, ptrav4, codre2)
 334 c
 335         codre0 = min ( codre1, codre2 )
 336         codret = max ( abs(codre0), codret,
 337      >                 codre1, codre2 )
 338       endif
 339 c
 340       call gmliat ( nhnoeu, 2, dimcst, codre0 )
 341       codret = max ( abs(codre0), codret )
 342 c
 343       if ( nbmpto.ne.0 ) then
 344 c
 345         iaux = 518
 346 #ifdef _DEBUG_HOMARD_
 347       write (ulsort,texte(langue,3)) 'UTAD02_mp', nompro
 348 #endif
 349         call utad02 (   iaux, nhmapo,
 350      >                phetmp, pnoemp,   jaux,  jaux,
 351      >                pfammp, pcfamp,   jaux,
 352      >                  jaux,   jaux,   jaux,
 353      >                  jaux,   jaux,   jaux,
 354      >                ulsort, langue, codret )
 355 c
 356       endif
 357 c
 358       iaux = 518
 359       if ( .not. cforme ) then
 360         iaux = iaux*15
 361       endif
 362       if ( degre.eq.2 ) then
 363         iaux = iaux*13
 364       endif
 365 #ifdef _DEBUG_HOMARD_
 366       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 367 #endif
 368       call utad02 (   iaux, nharet,
 369      >              phetar, psomar, pfilar, pmerar,
 370      >              pfamar, pcfaar,   jaux,
 371      >                jaux, pnp2ar,   jaux,
 372      >                jaux,   jaux,   jaux,
 373      >              ulsort, langue, codret )
 374 c
 375       if ( nbftri.ne.0 ) then
 376 c
 377         iaux = 37
 378         if ( nbtrto.ne.0 ) then
 379           iaux = iaux*2310
 380           if ( mod(mailet,2).eq.0 ) then
 381             iaux = iaux*19
 382           endif
 383         endif
 384 #ifdef _DEBUG_HOMARD_
 385       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 386 #endif
 387         call utad02 (   iaux, nhtria,
 388      >                phettr, paretr, pfiltr, ppertr,
 389      >                pfamtr, pcfatr,   jaux,
 390      >                pnivtr,   jaux,   jaux,
 391      >                adnmtr,   jaux,   jaux,
 392      >                ulsort, langue, codret )
 393 c
 394       endif
 395 c
 396       if ( nbfqua.ne.0 ) then
 397 c
 398         iaux = 37
 399         if ( nbquto.ne.0 ) then
 400           iaux = iaux*2310
 401           if ( mod(mailet,3).eq.0 ) then
 402             iaux = iaux*19
 403           endif
 404         endif
 405 #ifdef _DEBUG_HOMARD_
 406       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 407 #endif
 408         call utad02 (   iaux, nhquad,
 409      >                phetqu, parequ, pfilqu, pperqu,
 410      >                pfamqu, pcfaqu,   jaux,
 411      >                pnivqu,   jaux,   jaux,
 412      >                adnmqu,   jaux,   jaux,
 413      >                ulsort, langue, codret )
 414 c
 415       endif
 416 c
 417       if ( nbftet.ne.0 ) then
 418 c
 419 cgn        write(ulsort,90002) 'nbtecf, nbteca', nbtecf, nbteca
 420         iaux = 37
 421         if ( nbteto.ne.0 ) then
 422           iaux = iaux*182
 423           if ( nbteca.gt.0 ) then
 424             iaux = iaux*31
 425           endif
 426         endif
 427 #ifdef _DEBUG_HOMARD_
 428       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 429 #endif
 430         call utad02 (   iaux, nhtetr,
 431      >                phette, ptrite,   jaux,  jaux,
 432      >                pfamte, pcfate,   jaux,
 433      >                  jaux, pcotrt,   jaux,
 434      >                  jaux,   jaux, parete,
 435      >                ulsort, langue, codret )
 436 c
 437       endif
 438 c
 439       if ( nbfhex.ne.0 ) then
 440 c
 441         iaux = 37
 442         if ( nbheto.ne.0 ) then
 443           iaux = iaux*182
 444           if ( mod(mailet,5).eq.0 ) then
 445             iaux = iaux*19
 446           endif
 447           if ( nbheca.gt.0 ) then
 448             iaux = iaux*31
 449           endif
 450         endif
 451 #ifdef _DEBUG_HOMARD_
 452       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 453 #endif
 454         call utad02 (   iaux, nhhexa,
 455      >                phethe, pquahe,   jaux,  jaux,
 456      >                pfamhe, pcfahe,   jaux,
 457      >                  jaux, pcoquh,   jaux,
 458      >                adnmhe,   jaux, parehe,
 459      >                ulsort, langue, codret )
 460 c
 461       endif
 462 c
 463       if ( nbfpyr.ne.0 ) then
 464 c
 465         iaux = 37
 466         if ( nbpyto.ne.0 ) then
 467           iaux = iaux*182
 468           if ( nbpyca.gt.0 ) then
 469             iaux = iaux*31
 470           endif
 471         endif
 472 #ifdef _DEBUG_HOMARD_
 473       write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
 474 #endif
 475         call utad02 (   iaux, nhpyra,
 476      >                phetpy, pfacpy,   jaux,  jaux,
 477      >                pfampy, pcfapy,   jaux,
 478      >                  jaux, pcofay,   jaux,
 479      >                  jaux,   jaux, parepy,
 480      >                ulsort, langue, codret )
 481 c
 482       endif
 483 c
 484       if ( nbfpen.ne.0 ) then
 485 c
 486         iaux = 37
 487         if ( nbpeto.ne.0 ) then
 488           iaux = iaux*182
 489           if ( nbpeca.gt.0 ) then
 490             iaux = iaux*31
 491           endif
 492         endif
 493 #ifdef _DEBUG_HOMARD_
 494       write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 495 #endif
 496         call utad02 (   iaux, nhpent,
 497      >                phetpe, pfacpe,   jaux,  jaux,
 498      >                pfampe, pcfape,   jaux,
 499      >                  jaux, pcofap,   jaux,
 500      >                  jaux,   jaux, parepe,
 501      >                ulsort, langue, codret )
 502 c
 503       endif
 504 c
 505       call gmliat ( nhsups, 2, iaux, codre1 )
 506       call gmliat ( nhsupe, 9, nbfmed, codre2 )
 507 c
 508       codre0 = min ( codre1, codre2 )
 509       codret = max ( abs(codre0), codret,
 510      >               codre1, codre2 )
 511 c
 512       ngrouc = iaux / 10
 513 cgn      print *,nompro,'nbfmed, ngrouc ',nbfmed, ngrouc
 514 c
 515       endif
 516 c
 517 c 2.4. ==> les voisinages des noeuds
 518 c
 519       if ( codret.eq.0 ) then
 520 c
 521       iaux = 1
 522       jaux = 0
 523       kaux = 0
 524       laux = 0
 525 #ifdef _DEBUG_HOMARD_
 526       write (ulsort,texte(langue,3)) 'UTVOIS', nompro
 527 #endif
 528       call utvois ( nomail, nhvois,
 529      >                iaux,   jaux,   kaux,   laux,
 530      >              ppovos, pvoiso,
 531      >              nbfaar, pposif, pfacar,
 532      >              ulsort, langue, codret )
 533 c
 534       endif
 535 c
 536       if ( codret.eq.0 ) then
 537 c
 538       iaux = 3
 539       if ( nbteto.ne.0 ) then
 540         iaux = iaux*5
 541         if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then
 542           iaux = iaux*13
 543         endif
 544       endif
 545       if ( nbheto.ne.0 ) then
 546         iaux = iaux*7
 547         if ( nbpyto.ne.0 .or. nbpeto.ne.0 ) then
 548           iaux = iaux*17
 549         endif
 550       endif
 551 #ifdef _DEBUG_HOMARD_
 552       write (ulsort,texte(langue,3)) 'UTAD04', nompro
 553 #endif
 554       call utad04 ( iaux, nhvois,
 555      >                jaux,   jaux, pposif, pfacar,
 556      >              advotr, advoqu,
 557      >                jaux,   jaux, adpptr, adppqu,
 558      >                jaux,   jaux,   jaux,
 559      >                jaux,   jaux,   jaux,
 560      >                jaux,   jaux,   jaux,
 561      >                jaux,   jaux,   jaux,
 562      >              ulsort, langue, codret )
 563 c
 564       endif
 565 c
 566 c 2.5. ==> nombre d'equivalences
 567 #ifdef _DEBUG_HOMARD_
 568       write (ulsort,90002) '2.5. equivalences ; codret', codret
 569 #endif
 570 c
 571       if ( codret.eq.0 ) then
 572 c
 573       if ( homolo.eq.0 ) then
 574         nbequi = 0
 575       else
 576         call gmliat ( nhsups, 5, iaux, codret )
 577         if ( codret.eq.0 ) then
 578         if ( mod(iaux,33).eq.0 ) then
 579           nbequi = iaux / 33
 580         else
 581           codret = 3
 582         endif
 583         endif
 584       endif
 585 c
 586       endif
 587 c
 588 c====
 589 c 3. Particularites des logiciels associes
 590 c    Il faut le faire maintenant, avant d'avoir converti le maillage
 591 c    du format HOMARD au format MED. En effet, ces programmes vont
 592 c    modifier/creer les familles med associes. Or cela est transfere au
 593 c    maillage de calcul par le programme pcmac1.
 594 c====
 595 c
 596 #ifdef _DEBUG_HOMARD_
 597       write (ulsort,90002) '3. Particularites ; codret', codret
 598       call dmflsh(iaux)
 599 #endif
 600 #ifdef _DEBUG_HOMARD_
 601       write (ulsort,90002) 'typcca', typcca
 602 #endif
 603 c
 604 c 3.1. ==> Creation des boites pour Athena
 605 c
 606       if ( typcca.eq.16 ) then
 607 c
 608 #ifdef _DEBUG_HOMARD_
 609       write (ulsort,90002) '3. Boites pour Athena ; codret', codret
 610 #endif
 611 c
 612       if ( codret.eq.0 ) then
 613 c
 614       call gmnomc ( nhquad//'.Famille', nhqufa, codret )
 615 c
 616       endif
 617 c
 618       if ( codret.eq.0 ) then
 619 c
 620 #ifdef _DEBUG_HOMARD_
 621       write (ulsort,texte(langue,3)) 'PCFAAT', nompro
 622 #endif
 623       call pcfaat ( typcca,
 624      >              nhsupe, nhsups, nhqufa,
 625      >              imem(phetar), imem(psomar),
 626      >              imem(phettr), imem(paretr),
 627      >              imem(phetqu), imem(parequ),
 628      >              imem(pperqu), imem(pnivqu),
 629      >              imem(ppovos), imem(pvoiso),
 630      >              imem(pposif), imem(pfacar),
 631      >              imem(pfamar), imem(pcfaar),
 632      >              imem(pfamtr), imem(pcfatr),
 633      >              imem(pfamqu), pcfaqu,
 634      >              ulsort, langue, codret )
 635 c attention : il est normal que l'on passe pcfaqu et pas imem(pcfaqu)
 636 c
 637       endif
 638 c
 639       endif
 640 c
 641 c 3.2. ==> Elements a recoller pour le non conforme
 642 c
 643       if ( .not. cforme ) then
 644 c
 645 #ifdef _DEBUG_HOMARD_
 646       write (ulsort,90002) '3. Recoller non conforme ;  codret', codret
 647       call dmflsh(iaux)
 648 #endif
 649 c
 650 c 3.2.1. ==> Copie des tableaux des etats : les numeros vont etre
 651 c            modifies temporairement ; il faut pouvoir les restituer
 652 c            apres la conversion
 653 c
 654       if ( codret.eq.0 ) then
 655 c
 656       iaux = 0
 657       call gmcpal ( nharet//'.HistEtat', ntrav1, iaux, jaux, codret )
 658 c
 659       endif
 660 c
 661       if ( codret.eq.0 ) then
 662 c
 663       if ( nbtrto.ne.0 ) then
 664 c
 665         call gmcpal ( nhtria//'.HistEtat', ntrav2, iaux, jaux, codret )
 666 c
 667       endif
 668 c
 669       endif
 670 c
 671       if ( codret.eq.0 ) then
 672 c
 673       if ( nbquto.ne.0 ) then
 674 c
 675         call gmcpal ( nhquad//'.HistEtat', ntrav3, iaux, jaux, codret )
 676 c
 677       endif
 678 c
 679       endif
 680 c
 681 c 3.2.2. ==> Recuperation du recollement initial
 682 #ifdef _DEBUG_HOMARD_
 683       write (ulsort,90002) '3.2.2. recollement initial ; codret', codret
 684 #endif
 685 c
 686       if ( codret.eq.0 ) then
 687 c
 688 #ifdef _DEBUG_HOMARD_
 689       write (ulsort,texte(langue,3)) 'UTAD03_ar', nompro
 690 #endif
 691       iaux = 462
 692       call utad03 ( iaux, nharet,
 693      >              nbanci, nbenrc,  jaux,
 694      >              adarra, adarrb,
 695      >              ulsort, langue, codret )
 696 c
 697       if ( nbtrto.gt.0 ) then
 698 c
 699 #ifdef _DEBUG_HOMARD_
 700       write (ulsort,texte(langue,3)) 'UTAD03_tr', nompro
 701 #endif
 702         if ( nbtrri.eq.0 ) then
 703           iaux = 5
 704         else
 705           iaux = 35
 706         endif
 707         call utad03 ( iaux, nhtria,
 708      >                jaux,  jaux, numead,
 709      >                adtrra,  jaux,
 710      >                ulsort, langue, codret )
 711 c
 712       endif
 713 c
 714       if ( nbquto.gt.0 ) then
 715 c
 716 #ifdef _DEBUG_HOMARD_
 717       write (ulsort,texte(langue,3)) 'UTAD03_qu', nompro
 718 #endif
 719         if ( nbquri.eq.0 ) then
 720           iaux = 5
 721         else
 722           iaux = 35
 723         endif
 724         call utad03 ( iaux, nhquad,
 725      >                jaux,  jaux, numead,
 726      >                adqura,  jaux,
 727      >                ulsort, langue, codret )
 728 c
 729       endif
 730 c
 731       endif
 732 c
 733 c 3.2.3. ==> Creation de la structure de memorisation des recollements
 734 c            Remarque : on dimensionne surement trop grand car tout ne
 735 c                       donne pas lieu a recollement, mais tant pis
 736 c            Remarque : on initialise a 0 pour la suite
 737 #ifdef _DEBUG_HOMARD_
 738       write (ulsort,90002) '3.2.3. creation structure ; codret', codret
 739 #endif
 740 c
 741       if ( codret.eq.0 ) then
 742 c
 743 #ifdef _DEBUG_HOMARD_
 744       write (ulsort,texte(langue,3)) 'UTAL41', nompro
 745 #endif
 746       call utal41 ( typcca, nonexm, nbanci, nbenrc,
 747      >              nbarto, nbarde,
 748      >              nbtrri, nbtrde,
 749      >              nbquri, nbqude,
 750      >              nbpeac, nbpyac,
 751      >              nospec,
 752      >              adarrc, adtrrc, adqurc,
 753      >              adterc, adherc, adperc, adpyrc,
 754      >              lgtrc1, lgtrc2, lgtrc3,
 755      >              lgtrc4, lgtrc5, lgtrc6, lgtrc7,
 756      >              ulsort, langue, codret )
 757 c
 758       endif
 759 #ifdef _DEBUG_HOMARD_
 760       write (ulsort,*) 'apres utal41'
 761       write (ulsort,90002) 'lgtrc1', lgtrc1
 762       write (ulsort,90002) 'lgtrc2', lgtrc2
 763       write (ulsort,90002) 'lgtrc3', lgtrc3
 764       write (ulsort,90002) 'lgtrc4', lgtrc4
 765       write (ulsort,90002) 'lgtrc5', lgtrc5
 766       write (ulsort,90002) 'lgtrc6', lgtrc6
 767       write (ulsort,90002) 'lgtrc7', lgtrc7
 768 #endif
 769 c
 770       if ( codret.eq.0 ) then
 771 c
 772       jaux = adarrc + 2*lgtrc1 - 1
 773       do 3231 , iaux = adarrc, jaux
 774         imem(iaux) = 0
 775  3231 continue
 776 c
 777       jaux = adtrrc + 2*lgtrc2 - 1
 778       do 3232 , iaux = adtrrc, jaux
 779         imem(iaux) = 0
 780  3232 continue
 781 c
 782       jaux = adqurc + 2*lgtrc3 - 1
 783       do 3233 , iaux = adqurc, jaux
 784         imem(iaux) = 0
 785  3233 continue
 786 c
 787       jaux = adterc + 3*lgtrc4 - 1
 788       do 3234 , iaux = adterc, jaux
 789         imem(iaux) = 0
 790  3234 continue
 791 c
 792       jaux = adherc + 3*lgtrc5 - 1
 793       do 3235 , iaux = adherc, jaux
 794         imem(iaux) = 0
 795  3235 continue
 796 c
 797       jaux = adperc + 3*lgtrc6 - 1
 798       do 3236 , iaux = adperc, jaux
 799         imem(iaux) = 0
 800  3236 continue
 801 c
 802       jaux = adpyrc + 3*lgtrc7 - 1
 803       do 3237 , iaux = adpyrc, jaux
 804         imem(iaux) = 0
 805  3237 continue
 806 c
 807       endif
 808 c
 809 c 3.2.4. ==> Prise en compte du futur recollement
 810 #ifdef _DEBUG_HOMARD_
 811       write (ulsort,90002) '3.2.4. futur recollement ; codret', codret
 812 #endif
 813 c
 814       if ( codret.eq.0 ) then
 815 c
 816 #ifdef _DEBUG_HOMARD_
 817       write (ulsort,texte(langue,3)) 'PCMAR0', nompro
 818       call dmflsh(iaux)
 819 #endif
 820       call pcmar0 ( nonexm,
 821      >              imem(phetar), imem(pfilar), imem(pmerar),
 822      >              imem(pfamar), imem(pposif), imem(pfacar),
 823      >              imem(paretr), imem(phettr), imem(pnivtr),
 824      >              imem(pfamtr), imem(ppertr), imem(pfiltr),
 825      >              imem(parequ), imem(phetqu), imem(pnivqu),
 826      >              imem(pfamqu), imem(pperqu), imem(pfilqu),
 827      >              imem(phette),
 828      >              imem(phethe),
 829      >              imem(phetpy),
 830      >              imem(advotr), imem(adpptr),
 831      >              imem(advoqu), imem(adppqu),
 832      >              nbanci, nbenrc, numead,
 833      >              imem(adarra), imem(adtrra), imem(adqura),
 834      >              nparrc, nptrrc, npqurc,
 835      >              npterc, npherc, npperc, nppyrc,
 836      >              imem(adarrc), imem(adtrrc), imem(adqurc),
 837      >              imem(adterc), imem(adherc),
 838      >              imem(adperc), imem(adpyrc),
 839      >              ulsort, langue, codret )
 840 c
 841       endif
 842 c
 843 c 3.2.5. ==> Redimensionnement
 844 #ifdef _DEBUG_HOMARD_
 845       write (ulsort,90002) '3.2.5. Redimensionnement ; codret', codret
 846 #endif
 847 c
 848       if ( codret.eq.0 ) then
 849 c
 850 #ifdef _DEBUG_HOMARD_
 851       write (ulsort,*) 'au debut de 3.2.5'
 852       write (ulsort,90002) 'lgtrc1, nparrc', lgtrc1, nparrc
 853       write (ulsort,90002) 'lgtrc2, nptrrc', lgtrc2, nptrrc
 854       write (ulsort,90002) 'lgtrc3, npqurc', lgtrc3, npqurc
 855       write (ulsort,90002) 'lgtrc4, npterc', lgtrc4, npterc
 856       write (ulsort,90002) 'lgtrc5, npherc', lgtrc5, npherc
 857       write (ulsort,90002) 'lgtrc6, nptrrc+npqurc', lgtrc6, nptrrc+npqurc
 858       write (ulsort,90002) 'lgtrc7, nptrrc+npqurc', lgtrc7, nptrrc+npqurc
 859 #endif
 860 c
 861       call gmecat ( nospec, 1, nparrc, codre1 )
 862       call gmmod ( nospec//'.Tab1', adarrc,
 863      >             2, 2, lgtrc1, nparrc, codre2 )
 864 c
 865       codre0 = min ( codre1, codre2 )
 866       codret = max ( abs(codre0), codret,
 867      >               codre1, codre2 )
 868 c
 869       call gmecat ( nospec, 2, nptrrc, codre1 )
 870       call gmmod ( nospec//'.Tab2', adtrrc,
 871      >             2, 2, lgtrc2, nptrrc, codre2 )
 872       call gmecat ( nospec, 3, npqurc, codre3 )
 873       call gmmod ( nospec//'.Tab3', adqurc,
 874      >             2, 2, lgtrc3, npqurc, codre4 )
 875 c
 876       codre0 = min ( codre1, codre2, codre3, codre4 )
 877       codret = max ( abs(codre0), codret,
 878      >               codre1, codre2, codre3, codre4 )
 879 c
 880       call gmecat ( nospec, 4, npterc, codre1 )
 881       call gmmod ( nospec//'.Tab4', adterc,
 882      >             3, 3, lgtrc4, npterc, codre2 )
 883       call gmecat ( nospec, 5, npherc, codre3 )
 884       call gmmod ( nospec//'.Tab5', adherc,
 885      >             3, 3, lgtrc5, npherc, codre4 )
 886 c
 887       codre0 = min ( codre1, codre2, codre3, codre4 )
 888       codret = max ( abs(codre0), codret,
 889      >               codre1, codre2, codre3, codre4 )
 890 c
 891       if ( nbpeac.gt.0 ) then
 892         call gmecat ( nospec, 6, nptrrc+npqurc, codre1 )
 893         call gmmod ( nospec//'.Tab6', adperc,
 894      >               3, 3, lgtrc6, nptrrc+npqurc, codre2 )
 895       else
 896         codre1 = 0
 897         codre2 = 0
 898       endif
 899       if ( nbpyac.gt.0 ) then
 900         call gmecat ( nospec, 7, nptrrc+npqurc, codre3 )
 901         call gmmod ( nospec//'.Tab7', adpyrc,
 902      >               3, 3, lgtrc7, nptrrc+npqurc, codre4 )
 903       else
 904         codre3 = 0
 905         codre4 = 0
 906       endif
 907 c
 908       codre0 = min ( codre1, codre2, codre3, codre4 )
 909       codret = max ( abs(codre0), codret,
 910      >               codre1, codre2, codre3, codre4 )
 911 c
 912 cgn      call gmprsx (nompro,nospec)
 913 cgn      call gmprsx (nompro,nospec//'.Tab1')
 914 cgn      call gmprsx (nompro,nospec//'.Tab2')
 915 cgn      call gmprsx (nompro,nospec//'.Tab3')
 916 cgn      call gmprsx (nompro,nospec//'.Tab4')
 917 cgn      call gmprsx (nompro,nospec//'.Tab5')
 918 cgn      call gmprsx (nompro,nospec//'.Tab6')
 919 cgn      call gmprsx (nompro,nospec//'.Tab7')
 920 c
 921       endif
 922 c
 923       endif
 924 c
 925 c====
 926 c 4. preliminaires
 927 c====
 928 c
 929 #ifdef _DEBUG_HOMARD_
 930       write (ulsort,90002) '4. preliminaires ; codret', codret
 931       call dmflsh(iaux)
 932 #endif
 933 c
 934 c 4.1. ==> nombres caracteristiques
 935 c
 936       if ( codret.eq.0 ) then
 937 c
 938       call gmliat ( nhelig, 1, nbelig, codret )
 939 c
 940       endif
 941 c
 942 c 4.2. ==> on n'ordonne pas les noeuds
 943 c
 944 c      noeord = .true.
 945       noeord = .false.
 946 c
 947 c====
 948 c 5. Calcul du nombre d'entites pour le calcul.
 949 c    . Pour les noeuds, il y en a tout le temps et leur nombre
 950 c      est egal au nombre de noeuds.
 951 c    . Pour les aretes, les triangles ou les quadrangles, il est
 952 c      impossible d'avoir une estimation correcte a cause de la
 953 c      conformite qui fait apparaitre ou disparaitre des mailles.
 954 c      On appelle donc un programme qui fait le decompte.
 955 c    . Pour les mailles 3D, c'ets simple : il y a equivalence
 956 c      entre maille active et maille qui sera du calcul ensuite.
 957 c    Une fois ces estimations faites, on peut deduire le nombre
 958 c    total de mailles de calcul.
 959 c====
 960 #ifdef _DEBUG_HOMARD_
 961       write (ulsort,90002) 'au debut de 5. ; codret', codret
 962 #endif
 963 c
 964 c 5.1. ==> estimation du nombre d'elements du maillage de calcul
 965 c
 966       nbele0 = nbelig
 967 c
 968 c 5.2. ==> les noeuds
 969 c
 970       rsnoac = nbnoto
 971       rsnoto = nbnoto
 972       rsnois = nbnois
 973       rsnoei = nbnoei
 974       rsnomp = nbnomp
 975       rsnop1 = nbnop1
 976       rsnop2 = nbnop2
 977       rsnoim = nbnoim
 978 c
 979 c 5.3. ==> les mailles-points
 980 c
 981       if ( codret.eq.0 ) then
 982 c
 983       if ( nbmpto.eq.0 ) then
 984         rsmpto = 0
 985       else
 986         rsmpto = nbmpto
 987       endif
 988 c
 989       nbele0 = nbele0 + rsmpto
 990 c
 991       endif
 992 c
 993 c 5.4. ==> les aretes
 994 c
 995       if ( codret.eq.0 ) then
 996 c
 997       if ( nbarac.eq.0 ) then
 998         rsarto = 0
 999       elseif ( mod(nonexm,2).eq.0 ) then
1000         rsarto = 0
1001       else
1002 #ifdef _DEBUG_HOMARD_
1003       write (ulsort,texte(langue,3)) 'PCMAA0', nompro
1004 #endif
1005         call pcmaa0 ( rsarto,
1006      >                imem(phetar),
1007      >                imem(pfamar), imem(pcfaar),
1008      >                ulsort, langue, codret )
1009       endif
1010 c
1011       nbele0 = nbele0 + rsarto
1012 c
1013       endif
1014 c
1015 c 5.5. ==> les triangles
1016 c
1017       if ( codret.eq.0 ) then
1018 c
1019       if ( nbtrac.eq.0 ) then
1020         rstrto = 0
1021       else
1022 #ifdef _DEBUG_HOMARD_
1023       write (ulsort,texte(langue,3)) 'PCMAT0', nompro
1024 #endif
1025         call pcmat0 ( rstrto,
1026      >                imem(phettr),
1027      >                imem(pfamtr), imem(pcfatr),
1028      >                ulsort, langue, codret )
1029       endif
1030 c
1031       nbele0 = nbele0 + rstrto
1032 c
1033       endif
1034 c
1035 c 5.6. ==> les quadrangles
1036 c
1037       if ( codret.eq.0 ) then
1038 c
1039       if ( nbquac.eq.0 ) then
1040         rsquto = 0
1041       else
1042 #ifdef _DEBUG_HOMARD_
1043       write (ulsort,texte(langue,3)) 'PCMAQ0', nompro
1044 #endif
1045         call pcmaq0 ( rsquto,
1046      >                imem(phetqu),
1047      >                imem(pfamqu), imem(pcfaqu),
1048      >                ulsort, langue, codret )
1049 #ifdef _DEBUG_HOMARD_
1050       write (ulsort,90002) 'rsquto', rsquto
1051 #endif
1052       endif
1053 c
1054       nbele0 = nbele0 + rsquto
1055 c
1056       endif
1057 c
1058 c 5.8. ==> les tetraedres
1059 c
1060       if ( codret.eq.0 ) then
1061 c
1062       if ( nbteac.eq.0 ) then
1063         rsteto = 0
1064       else
1065         rsteto = nbteto
1066       endif
1067 c
1068       nbele0 = nbele0 + rsteto
1069 c
1070       endif
1071 c
1072 c 5.9. ==> les hexaedres
1073 c
1074       if ( codret.eq.0 ) then
1075 c
1076       if ( nbheac.eq.0 ) then
1077         rsheto = 0
1078       else
1079         rsheto = nbheto
1080       endif
1081 c
1082       nbele0 = nbele0 + rsheto
1083 c
1084       endif
1085 c
1086 c 5.10. ==> les pyramides
1087 c
1088       if ( codret.eq.0 ) then
1089 c
1090       if ( nbpyac.eq.0 ) then
1091         rspyto = 0
1092       else
1093         rspyto = nbpyto
1094       endif
1095 c
1096       nbele0 = nbele0 + rspyto
1097 c
1098       endif
1099 c
1100 c 5.11. ==> les pentaedres
1101 c
1102       if ( codret.eq.0 ) then
1103 c
1104       if ( nbpeac.eq.0 ) then
1105         rspeto = 0
1106       else
1107         rspeto = nbpeto
1108       endif
1109 c
1110       nbele0 = nbele0 + rspeto
1111 c
1112       endif
1113 c
1114 #ifdef _DEBUG_HOMARD_
1115       write (ulsort,texte(langue,18)) mess14(langue,3,13), nbele0
1116 #endif
1117 c
1118 #ifdef _DEBUG_HOMARD_
1119       write (ulsort,90002) 'apres les 5.3.x ; codret', codret
1120       call dmflsh(iaux)
1121 #endif
1122 c
1123 c====
1124 c 6. allocation des tableaux pour le maillage de sortie
1125 c====
1126 c
1127 #ifdef _DEBUG_HOMARD_
1128       write (ulsort,90002) '6. allocation des tableaux ; codret', codret
1129 #endif
1130 c
1131 c 6.1. ==> allocation de l'objet de tete
1132 c          remarque : pour le moment, ncfron n'est pas alloue
1133 c
1134       if ( codret.eq.0 ) then
1135 c
1136       iaux = 0
1137       jaux = 2
1138 #ifdef _DEBUG_HOMARD_
1139       write (ulsort,90002) 'sdimca, mdimca', sdimca, mdimca
1140       write (ulsort,90002) 'nbnoto, nctfno, nbele0, nbmane',
1141      >                      nbnoto, nctfno, nbele0, nbmane
1142       write (ulsort,texte(langue,3)) 'UTACMA', nompro
1143 #endif
1144       call utacma ( nocmap, iaux, typcca,
1145      >              sdimca, mdimca,
1146      >               degre, mailet, maconf, homolo, hierar,
1147      >              nbnoto, nctfno, nbele0, nbmane,  jaux,
1148      >              ncinfo, ncnoeu, nccono, nccode,
1149      >              nccoex, ncfami,
1150      >              ncequi, ncfron, ncnomb,
1151      >              ulsort, langue, codret )
1152 c
1153       endif
1154 c
1155 c 6.2. ==> tableaux de correspondance entre les numerotations
1156 #ifdef _DEBUG_HOMARD_
1157       write (ulsort,90002) 'au debut de 6.2 ; codret', codret
1158 #endif
1159 c
1160 c 6.2.1 ==> les noeuds
1161 c
1162       if ( codret.eq.0 ) then
1163 c
1164       iaux = -1
1165       kaux = 210
1166 #ifdef _DEBUG_HOMARD_
1167       write (ulsort,texte(langue,3)) 'UTRE01_no', nompro
1168 #endif
1169       call utre01 ( iaux, kaux,
1170      >              norenu, rsnoac, rsnoto,
1171      >              adnohp, adnocp, laux,
1172      >              ulsort, langue, codret)
1173 c
1174       endif
1175 c
1176 c 6.2.2. ==> les mailles-points
1177 c
1178       if ( codret.eq.0 ) then
1179 c
1180       iaux = 0
1181       if ( rsmpto.eq.0 ) then
1182         jaux = 0
1183       else
1184         jaux = nbele0
1185       endif
1186       kaux = 210
1187 #ifdef _DEBUG_HOMARD_
1188       write (ulsort,texte(langue,3)) 'UTRE01_mp', nompro
1189 #endif
1190       call utre01 ( iaux, kaux, norenu,   jaux, rsmpto,
1191      >              admphp, admpcp, laux,
1192      >              ulsort, langue, codret)
1193 c
1194       endif
1195 c
1196 c 6.2.3. ==> les aretes
1197 c
1198       if ( codret.eq.0 ) then
1199 c
1200 #ifdef _DEBUG_HOMARD_
1201       write (ulsort,texte(langue,3)) 'UTRE01_ar', nompro
1202 #endif
1203       iaux = 1
1204       if ( rsarto.eq.0 ) then
1205         jaux = 0
1206       else
1207         jaux = nbele0
1208       endif
1209       kaux = 210
1210       call utre01 ( iaux, kaux, norenu,   jaux, rsarto,
1211      >              adarhp, adarcp, laux,
1212      >              ulsort, langue, codret)
1213 c
1214       endif
1215 c
1216 c 6.2.4. ==> les triangles
1217 c
1218       if ( codret.eq.0 ) then
1219 c
1220       iaux = 2
1221       if ( rstrto.eq.0 ) then
1222         jaux = 0
1223       else
1224         jaux = nbele0
1225       endif
1226       kaux = 210
1227 #ifdef _DEBUG_HOMARD_
1228       write (ulsort,texte(langue,3)) 'UTRE01_tr', nompro
1229 #endif
1230       call utre01 ( iaux, kaux, norenu,   jaux, rstrto,
1231      >              adtrhp, adtrcp, laux,
1232      >              ulsort, langue, codret)
1233 c
1234       endif
1235 c
1236 c 6.2.5. ==> les quadrangles
1237 c
1238       if ( codret.eq.0 ) then
1239 c
1240       iaux = 4
1241       if ( rsquto.eq.0 ) then
1242         jaux = 0
1243       else
1244         jaux = nbele0
1245       endif
1246       kaux = 210
1247 #ifdef _DEBUG_HOMARD_
1248       write (ulsort,texte(langue,3)) 'UTRE01_qu', nompro
1249 #endif
1250       call utre01 ( iaux, kaux, norenu,   jaux, rsquto,
1251      >              adquhp, adqucp, laux,
1252      >              ulsort, langue, codret)
1253 c
1254       endif
1255 c
1256 c 6.2.6. ==> les tetraedres
1257 c
1258       if ( codret.eq.0 ) then
1259 c
1260       iaux = 3
1261       if ( rsteto.eq.0 ) then
1262         jaux = 0
1263       else
1264         jaux = nbele0
1265       endif
1266       kaux = 210
1267 #ifdef _DEBUG_HOMARD_
1268       write (ulsort,texte(langue,3)) 'UTRE01_te', nompro
1269 #endif
1270       call utre01 ( iaux, kaux, norenu,   jaux, rsteto,
1271      >              adtehp, adtecp, laux,
1272      >              ulsort, langue, codret)
1273 c
1274       endif
1275 c
1276 c 6.2.7. ==> les hexaedres
1277 c
1278       if ( codret.eq.0 ) then
1279 c
1280       iaux = 6
1281       if ( rsheto.eq.0 ) then
1282         jaux = 0
1283       else
1284         jaux = nbele0
1285       endif
1286       kaux = 210
1287 #ifdef _DEBUG_HOMARD_
1288       write (ulsort,texte(langue,3)) 'UTRE01_he', nompro
1289 #endif
1290       call utre01 ( iaux, kaux, norenu,   jaux, rsheto,
1291      >              adhehp, adhecp, laux,
1292      >              ulsort, langue, codret)
1293 c
1294       endif
1295 c
1296 c 6.2.8. ==> les pyramides
1297 c
1298       if ( codret.eq.0 ) then
1299 c
1300       iaux = 5
1301       if ( rspyto.eq.0 ) then
1302         jaux = 0
1303       else
1304         jaux = nbele0
1305       endif
1306       kaux = 210
1307 #ifdef _DEBUG_HOMARD_
1308       write (ulsort,texte(langue,3)) 'UTRE01_py', nompro
1309 #endif
1310       call utre01 ( iaux, kaux, norenu,   jaux, rspyto,
1311      >              adpyhp, adpycp, laux,
1312      >              ulsort, langue, codret)
1313 c
1314       endif
1315 c
1316 c 6.2.9. ==> les pentaedres
1317 c
1318       if ( codret.eq.0 ) then
1319 c
1320       iaux = 7
1321       if ( rspeto.eq.0 ) then
1322         jaux = 0
1323       else
1324         jaux = nbele0
1325       endif
1326       kaux = 210
1327 #ifdef _DEBUG_HOMARD_
1328       write (ulsort,texte(langue,3)) 'UTRE01_pe', nompro
1329 #endif
1330       call utre01 ( iaux, kaux, norenu,   jaux, rspeto,
1331      >              adpehp, adpecp, laux,
1332      >              ulsort, langue, codret)
1333 c
1334       endif
1335 c
1336 c 6.2.10. ==> les nombres
1337 c
1338       if ( codret.eq.0 ) then
1339 c
1340       iaux = 25
1341       call gmecat ( norenu, 19, iaux, codre1 )
1342       call gmaloj ( norenu//'.Nombres', ' ', iaux, adnbrp, codre2 )
1343 c
1344       codre0 = min ( codre1, codre2 )
1345       codret = max ( abs(codre0), codret,
1346      >               codre1, codre2 )
1347 c
1348       endif
1349 #ifdef _DEBUG_HOMARD_
1350       write (ulsort,90002) 'apres les 6.2.x ; codret', codret
1351       call dmflsh(iaux)
1352 #endif
1353 c
1354 c 6.3. ==> structure de donnees de type externe : on prend large pour
1355 c          le nombre de mailles
1356 #ifdef _DEBUG_HOMARD_
1357       write (ulsort,90002) '6.3. structure externe ; codret', codret
1358       call dmflsh(iaux)
1359 #endif
1360 c
1361       if ( codret.eq.0 ) then
1362 c
1363       iaux = nbnoto * sdimca
1364       call gmaloj ( ncnoeu//'.Coor', ' ', iaux, pcoonc, codre1 )
1365       call gmaloj ( ncnoeu//'.FamilMED', ' ', nbnoto, pfamen, codre2 )
1366 c
1367       codre0 = min ( codre1, codre2 )
1368       codret = max ( abs(codre0), codret,
1369      >               codre1, codre2 )
1370 c
1371       call gmecat ( ncnoeu, 3, dimcst, codre1 )
1372       call gmcpoj ( nhnoeu//'.CoorCons', ncnoeu//'.CoorCons', codre2 )
1373       call gmadoj ( nhnoeu//'.CoorCons', adcocs, iaux, codre3 )
1374 c
1375       codre0 = min ( codre1, codre2, codre3 )
1376       codret = max ( abs(codre0), codret,
1377      >               codre1, codre2, codre3 )
1378 c
1379       call gmaloj ( nccono//'.FamilMED', ' ', nbele0, pfamee, codre1 )
1380       iaux = nbele0*nbmane
1381       call gmaloj ( nccono//'.Noeuds', ' ', iaux  , pnoeel, codre2 )
1382       call gmaloj ( nccono//'.Type', ' ', nbele0, ptypel, codre3 )
1383 c
1384       codre0 = min ( codre1, codre2, codre3 )
1385       codret = max ( abs(codre0), codret,
1386      >               codre1, codre2, codre3 )
1387 c
1388       endif
1389 c
1390 c 6.4. ==> transfert des mailles ignorees
1391 #ifdef _DEBUG_HOMARD_
1392       write (ulsort,90002) '6.4. ==> transfert ignores ; codret', codret
1393       write (ulsort,90002) 'nbelig', nbelig
1394       call dmflsh(iaux)
1395 #endif
1396 c
1397       if ( nbelig.ne.0 ) then
1398 c
1399         if ( codret.eq.0 ) then
1400 c
1401 cgn      call gmprsx (nompro, nhelig )
1402 cgn      call gmprsx (nompro, nhelig//'.ConnNoeu' )
1403 cgn      call gmprsx (nompro, nhelig//'.FamilMED' )
1404 c
1405         call gmadoj ( nhelig//'.ConnNoeu', hnoeel, iaux, codre1 )
1406         call gmadoj ( nhelig//'.FamilMED', hfmdel, iaux, codre2 )
1407 c
1408         codre0 = min ( codre1, codre2 )
1409         codret = max ( abs(codre0), codret,
1410      >                 codre1, codre2 )
1411 c
1412         endif
1413 c
1414         if ( codret.eq.0 ) then
1415 c
1416 #ifdef _DEBUG_HOMARD_
1417         write (ulsort,texte(langue,3)) 'UTINEI', nompro
1418 #endif
1419         call utinei ( modhom,
1420      >                ulsort, langue, codret )
1421 c
1422         endif
1423 c
1424       endif
1425 c
1426 #ifdef _DEBUG_HOMARD_
1427 c
1428 c====
1429 c 7. impressions
1430 c====
1431 c
1432 #ifdef _DEBUG_HOMARD_
1433       write (ulsort,90002) '7. impressions ; codret', codret
1434       call dmflsh(iaux)
1435 #endif
1436 cgn      call gmprsx (nompro, nhnofa//'.EntiFamm')
1437 cgn      call gmprsx (nompro, nhmpfa//'.EntiFamm')
1438 cgn      call gmprsx (nompro, nharfa//'.EntiFamm')
1439 cgn      call gmprsx (nompro, nhtrfa//'.EntiFamm')
1440 cgn      call gmprsx (nompro, nhqufa//'.EntiFamm')
1441 cgn      call gmprsx (nompro, nhtefa//'.EntiFamm')
1442 cgn      call gmmess(6)
1443 cgn      call gmprsx (nompro, nhtrfa//'.Codes')
1444 cgn      call gmprsx (nompro, nhqufa//'.Codes')
1445 cgn      ulsort = 6
1446 c
1447       if ( codret.eq.0 ) then
1448 c
1449       iaux = 0
1450 #ifdef _DEBUG_HOMARD_
1451       write (ulsort,texte(langue,3)) 'UTECFE', nompro
1452 #endif
1453       call utecfe ( iaux,
1454      >              imem(pfamno), imem(pcfano),
1455      >              imem(pfammp), imem(pcfamp),
1456      >              imem(pfamar), imem(pcfaar),
1457      >              imem(pfamtr), imem(pcfatr),
1458      >              imem(pfamqu), imem(pcfaqu),
1459      >              imem(pfamte), imem(pcfate),
1460      >              imem(pfamhe), imem(pcfahe),
1461      >              imem(pfampy), imem(pcfapy),
1462      >              imem(pfampe), imem(pcfape),
1463      >              ulsort, langue, codret )
1464 c
1465       endif
1466 c
1467 #endif
1468 c
1469 c====
1470 c 8. conversion vraie
1471 c====
1472 c
1473 #ifdef _DEBUG_HOMARD_
1474       write (ulsort,90002) '8. conversion vraie ; codret', codret
1475       call dmflsh(iaux)
1476 #endif
1477 c
1478       if ( codret.eq.0 ) then
1479 c
1480 #ifdef _DEBUG_HOMARD_
1481       write (ulsort,texte(langue,3)) 'PCMAC1', nompro
1482 #endif
1483       call pcmac1 ( nbele0,
1484      >   rmem(pcoono), imem(phetno), imem(pancno), imem(ptrav4),
1485      >   imem(pnoemp), imem(phetmp),
1486      >   imem(psomar), imem(pnp2ar), imem(phetar),
1487      >   imem(paretr), imem(phettr), imem(adnmtr),
1488      >   imem(parequ), imem(phetqu), imem(adnmqu),
1489      >   imem(ptrite), imem(pcotrt), imem(parete), imem(phette),
1490      >   imem(pquahe), imem(pcoquh), imem(parehe), imem(phethe),
1491      >   imem(adnmhe),
1492      >   imem(pfacpy), imem(pcofay), imem(parepy), imem(phetpy),
1493      >   imem(pfacpe), imem(pcofap), imem(parepe), imem(phetpe),
1494      >   imem(pfamno), imem(pcfano), imem(pfammp), imem(pcfamp),
1495      >   imem(pfamar), imem(pcfaar),
1496      >   imem(pfamtr), imem(pcfatr), imem(pfamqu), imem(pcfaqu),
1497      >   imem(pfamte), imem(pcfate), imem(pfamhe), imem(pcfahe),
1498      >   imem(pfampy), imem(pcfapy), imem(pfampe), imem(pcfape),
1499      >   imem(adnocp), imem(adnohp), imem(admpcp), imem(admphp),
1500      >   imem(adarcp), imem(adarhp),
1501      >   imem(adtrcp), imem(adtrhp), imem(adqucp), imem(adquhp),
1502      >   imem(adtecp), imem(adtehp), imem(adhecp), imem(adhehp),
1503      >   imem(adpycp), imem(adpyhp), imem(adpecp), imem(adpehp),
1504      >   dimcst, rmem(adcocs), rmem(pcoonc), imem(pfamen),
1505      >   imem(pfamee), imem(pnoeel), imem(ptypel),
1506      >   imem(hfmdel), imem(hnoeel),
1507      >   noeord, deraff,
1508      >   ulsort, langue, codret )
1509 c
1510       endif
1511 c
1512 c====
1513 c 9. finitions
1514 c====
1515 c
1516 #ifdef _DEBUG_HOMARD_
1517       write (ulsort,90002) '9. finitions ; codret', codret
1518       call dmflsh(iaux)
1519 #endif
1520 c
1521 c 9.1. ==> maintenant que l'on connait le vrai nombre de mailles au sens
1522 c          du calcul, on raccourcit eventuellement les tableaux
1523 c
1524 c 9.1.1. ==> les eventuelles mailles-points
1525 c
1526 #ifdef _DEBUG_HOMARD_
1527       write (ulsort,90002) '9.1.1. mailles-points ; codret', codret
1528       write (ulsort,90002) 'nbmpto', nbmpto
1529       write (ulsort,90002) 'rsmpac', rsmpac
1530       call dmflsh(iaux)
1531 #endif
1532 c
1533       if ( rsmpto.ne.0 ) then
1534 c
1535         if ( codret.eq.0 ) then
1536 c
1537         iaux = 0
1538         jaux = 6
1539 #ifdef _DEBUG_HOMARD_
1540       write (ulsort,texte(langue,3)) 'UTRE02_mp', nompro
1541 #endif
1542         call utre02 ( iaux,  jaux, norenu,
1543      >                nbele0, rsmpto, rsmpac, rsmpto,
1544      >                admphp, admpcp,
1545      >                ulsort, langue, codret)
1546 c
1547         endif
1548 c
1549       endif
1550 c
1551 c 9.1.2. ==> les aretes
1552 c
1553 #ifdef _DEBUG_HOMARD_
1554       write (ulsort,90002) '9.1.2. aretes ; codret', codret
1555       write (ulsort,90002) 'nbarto', nbarto
1556       call dmflsh(iaux)
1557 #endif
1558 c
1559       if ( rsarto.ne.0 ) then
1560 c
1561         if ( codret.eq.0 ) then
1562 c
1563         iaux = 1
1564         jaux = 6
1565 #ifdef _DEBUG_HOMARD_
1566         write (ulsort,texte(langue,3)) 'UTRE02_ar', nompro
1567 #endif
1568         call utre02 ( iaux,  jaux, norenu,
1569      >                nbele0, rsarto, rsarac, rsarto,
1570      >                adarhp, adarcp,
1571      >                ulsort, langue, codret)
1572 c
1573         endif
1574 c
1575       endif
1576 c
1577 c 9.1.3. ==> les eventuels triangles
1578 c
1579 #ifdef _DEBUG_HOMARD_
1580       write (ulsort,90002) '9.1.3. triangles ; codret', codret
1581       write (ulsort,90002) 'nbele0', nbele0
1582       write (ulsort,90002) 'nbtrto', nbtrto
1583       call dmflsh(iaux)
1584 #endif
1585 c
1586       if ( rstrto.ne.0 ) then
1587 c
1588         if ( codret.eq.0 ) then
1589 c
1590         iaux = 2
1591         jaux = 6
1592 #ifdef _DEBUG_HOMARD_
1593       write (ulsort,texte(langue,3)) 'UTRE02_tr', nompro
1594 #endif
1595         call utre02 ( iaux,  jaux, norenu,
1596      >                nbele0, rstrto, rstrac, rstrto,
1597      >                adtrhp, adtrcp,
1598      >                ulsort, langue, codret)
1599 c
1600         endif
1601 c
1602       endif
1603 c
1604 c 9.1.4. ==> les eventuels quadrangles
1605 c
1606 #ifdef _DEBUG_HOMARD_
1607       write (ulsort,90002) '9.1.4. quadrangles ; codret', codret
1608       write (ulsort,90002) 'nbele0', nbele0
1609       write (ulsort,90002) 'rsquac', rsquac
1610       write (ulsort,90002) 'nbquto', nbquto
1611       write (ulsort,90002) 'rsquto', rsquto
1612       call dmflsh(iaux)
1613 #endif
1614 c
1615       if ( rsquto.ne.0 ) then
1616 c
1617         if ( codret.eq.0 ) then
1618 c
1619         iaux = 4
1620         jaux = 6
1621 #ifdef _DEBUG_HOMARD_
1622       write (ulsort,texte(langue,3)) 'UTRE02_qu', nompro
1623 #endif
1624         call utre02 ( iaux,  jaux, norenu,
1625      >                nbele0, rsquto, rsquac, rsquto,
1626      >                adquhp, adqucp,
1627      >                ulsort, langue, codret)
1628 c
1629         endif
1630 c
1631       endif
1632 c
1633 c 9.1.5. ==> les eventuels tetraedres
1634 c
1635 #ifdef _DEBUG_HOMARD_
1636       write (ulsort,90002) '9.1.5. tetraedres ; codret', codret
1637       write (ulsort,90002) 'nbteto', nbteto
1638       call dmflsh(iaux)
1639 #endif
1640 c
1641       if ( rsteto.ne.0 ) then
1642 c
1643         if ( codret.eq.0 ) then
1644 c
1645         iaux = 3
1646         jaux = 6
1647 #ifdef _DEBUG_HOMARD_
1648       write (ulsort,texte(langue,3)) 'UTRE02_te', nompro
1649 #endif
1650         call utre02 ( iaux,  jaux, norenu,
1651      >                nbele0, rsteto, rsteac, rsteto,
1652      >                adtehp, adtecp,
1653      >                ulsort, langue, codret)
1654 c
1655         endif
1656 c
1657       endif
1658 c
1659 c 9.1.6. ==> les eventuelles pyramides
1660 c
1661 #ifdef _DEBUG_HOMARD_
1662       write (ulsort,90002) '9.1.6. pyramides ; codret', codret
1663       write (ulsort,90002) 'nbpyto', nbpyto
1664       call dmflsh(iaux)
1665 #endif
1666 c
1667       if ( rspyto.ne.0 ) then
1668 c
1669         if ( codret.eq.0 ) then
1670 c
1671         iaux = 5
1672         jaux = 6
1673 #ifdef _DEBUG_HOMARD_
1674       write (ulsort,texte(langue,3)) 'UTRE02_py', nompro
1675 #endif
1676         call utre02 ( iaux,  jaux, norenu,
1677      >                nbele0, rspyto, rspyac, rspyto,
1678      >                adpyhp, adpycp,
1679      >                ulsort, langue, codret)
1680 c
1681         endif
1682 c
1683       endif
1684 c
1685 c 9.1.7. ==> les eventuels hexaedres
1686 c
1687 #ifdef _DEBUG_HOMARD_
1688       write (ulsort,90002) '9.1.7. hexaedres ; codret', codret
1689       write (ulsort,90002) 'nbheto', nbheto
1690       call dmflsh(iaux)
1691 #endif
1692 c
1693       if ( rsheto.ne.0 ) then
1694 c
1695         if ( codret.eq.0 ) then
1696 c
1697         iaux = 6
1698         jaux = 6
1699 #ifdef _DEBUG_HOMARD_
1700       write (ulsort,texte(langue,3)) 'UTRE02_he', nompro
1701 #endif
1702         call utre02 ( iaux,  jaux, norenu,
1703      >                nbele0, rsheto, rsheac, rsheto,
1704      >                adhehp, adhecp,
1705      >                ulsort, langue, codret)
1706 c
1707         endif
1708 c
1709       endif
1710 c
1711 c 9.1.8. ==> les eventuels pentaedres
1712 c
1713 #ifdef _DEBUG_HOMARD_
1714       write (ulsort,90002) '9.1.8. pentaedres ; codret', codret
1715       write (ulsort,90002) 'nbpeto', nbpeto
1716       call dmflsh(iaux)
1717 #endif
1718 c
1719       if ( rspeto.ne.0 ) then
1720 c
1721         if ( codret.eq.0 ) then
1722 c
1723         iaux = 7
1724         jaux = 6
1725 #ifdef _DEBUG_HOMARD_
1726       write (ulsort,texte(langue,3)) 'UTRE02_pe', nompro
1727 #endif
1728         call utre02 ( iaux,  jaux, norenu,
1729      >                nbele0, rspeto, rspeac, rspeto,
1730      >                adpehp, adpecp,
1731      >                ulsort, langue, codret)
1732 c
1733         endif
1734 c
1735       endif
1736 c
1737 c 9.1.9. ==> les descriptions des mailles
1738 c
1739 #ifdef _DEBUG_HOMARD_
1740       write (ulsort,90002) '9.1.9. mailles ; codret', codret
1741       write (ulsort,90002) 'nbele0, nbelem, nbmane',
1742      >                      nbele0,nbelem,nbmane
1743       call dmflsh(iaux)
1744 #endif
1745 c
1746       if ( codret.eq.0 ) then
1747 c
1748       call gmmod ( nccono//'.FamilMED',
1749      >             pfamee, nbele0, nbelem, un, un, codre1 )
1750       call gmmod ( nccono//'.Type',
1751      >             ptypel, nbele0, nbelem, un, un, codre2 )
1752       call gmmod ( nccono//'.Noeuds',
1753      >             pnoeel, nbele0, nbelem, nbmane, nbmane, codre3 )
1754       call gmecat ( nccono, 1, nbelem, codre4 )
1755 c
1756       codre0 = min ( codre1, codre2, codre3, codre4 )
1757       codret = max ( abs(codre0), codret,
1758      >               codre1, codre2, codre3, codre4 )
1759 c
1760       endif
1761 cgn      call gmprsx (nompro//' - 8.1.9',nccono)
1762 cgn      call gmprsx (nompro//' - 8.1.9',nccono//'.Type')
1763 cgn      call gmprsx (nompro//' - 8.1.9',nccono//'.Noeuds')
1764 c
1765 c 9.2. ==> les caracteristiques du maillage de calcul
1766 c
1767 #ifdef _DEBUG_HOMARD_
1768       write (ulsort,90002) '9.2. carac. mail de calcul ; codret', codret
1769 #endif
1770 c
1771       if ( codret.eq.0 ) then
1772 c
1773       imem(adnbrp) = rsnois
1774       imem(adnbrp+1) = rsnoei
1775       imem(adnbrp+2) = rsnomp
1776       imem(adnbrp+3) = rsnop1
1777       imem(adnbrp+4) = rsnop2
1778       imem(adnbrp+5) = rsnoim
1779       imem(adnbrp+6) = rseutc
1780       imem(adnbrp+7) = rsevca
1781       imem(adnbrp+8) = rsevto
1782       imem(adnbrp+9) = nbelem
1783       imem(adnbrp+10) = nbmaae
1784       imem(adnbrp+11) = nbmafe
1785       imem(adnbrp+12) = nbmane
1786       imem(adnbrp+13) = nbmapo
1787       imem(adnbrp+14) = nbsegm
1788       imem(adnbrp+15) = nbtetr
1789       imem(adnbrp+16) = nbtria
1790       imem(adnbrp+17) = nbquad
1791       imem(adnbrp+18) = numael
1792       imem(adnbrp+19) = numano
1793       imem(adnbrp+20) = nvoare
1794       imem(adnbrp+21) = nvosom
1795       imem(adnbrp+22) = nbhexa
1796       imem(adnbrp+23) = nbpyra
1797       imem(adnbrp+24) = nbpent
1798 c
1799       endif
1800 c
1801 c 9.3. ==> Les nombres
1802 c
1803       if ( codret.eq.0 ) then
1804 c
1805       call gmadoj ( ncnomb, adnomb, iaux, codret )
1806 c
1807       endif
1808 cgn      print *,nbmaae, nbmafe, nbmnei, numano, numael
1809 cgn      print *,nbmapo,nbsegm,nbtria,nbtetr
1810 cgn      print *,nbelig,nbquad,nbhexa,nbpent,nbpyra
1811 c
1812       if ( codret.eq.0 ) then
1813 c
1814       imem(adnomb)    = nbmaae
1815       imem(adnomb+1)  = nbmafe
1816       imem(adnomb+2)  = nbmnei
1817       imem(adnomb+3)  = numano
1818       imem(adnomb+4)  = numael
1819       imem(adnomb+5)  = nbtria + nbquad
1820       imem(adnomb+6)  = nbtetr + nbhexa + nbpent + nbpyra
1821       imem(adnomb+11) = nbmapo
1822       imem(adnomb+12) = nbsegm
1823       imem(adnomb+13) = nbtria
1824       imem(adnomb+14) = nbtetr
1825       imem(adnomb+15) = nbelig
1826       imem(adnomb+16) = nbquad
1827       imem(adnomb+17) = nbhexa
1828       imem(adnomb+18) = nbpent
1829       imem(adnomb+19) = nbpyra
1830 c
1831 #ifdef _DEBUG_HOMARD_
1832       call gmprsx (nompro, ncnomb )
1833 #endif
1834 c
1835       endif
1836 c
1837 c 9.4. ==> date et heure
1838 c
1839       if ( codret.eq.0 ) then
1840 c
1841       call utdhus ( dateus, heurus )
1842 c
1843       endif
1844 c
1845 cmdc ---------------- MAILLES DOUBLES DEBUT --------------
1846 cmdc
1847 cmdc 3.4.1. ==> Lecture du numero de la couche en cours
1848 cmdc
1849 cmd      if ( codret.eq.0 ) then
1850 cmdc
1851 cmd      nomfic = 'nrc.dat'
1852 cmd      inquire ( file = nomfic, exist = maildb )
1853 cmdc
1854 cmd      endif
1855 cmdc
1856 cmd                   if ( maildb ) then
1857 cmdc
1858 cmd      nbele0 = nbelem
1859 cmd      nbele1 = nbele0 + nbtetr
1860 cmdcgn      write(ulsort,90002) 'nbele0', nbele0
1861 cmdcgn      write(ulsort,90002) 'nbele1', nbele1
1862 cmdcgn      write(ulsort,90002) 'nbfmed', nbfmed
1863 cmdc
1864 cmd      if ( codret.eq.0 ) then
1865 cmdc
1866 cmd      call gmadoj ( nhsupe//'.Tab5', adpoin, iaux, codre1 )
1867 cmd      call gmadoj ( nhsupe//'.Tab6', adtail, iaux, codre2 )
1868 cmd      call gmadoj ( nhsups//'.Tab2', adtabl, iaux, codre3 )
1869 cmd      call gmadoj ( nhsupe//'.Tab9', adnumf, iaux, codre4 )
1870 cmdc
1871 cmd      codre0 = min ( codre1, codre2, codre3, codre4 )
1872 cmd      codret = max ( abs(codre0), codret,
1873 cmd     >               codre1, codre2, codre3, codre4 )
1874 cmdc
1875 cmd      endif
1876 cmdc
1877 cmd      if ( codret.eq.0 ) then
1878 cmdc
1879 cmd      iaux = 3*nbfmed
1880 cmd      call gmalot ( ntrav5, 'entier  ', iaux, ptrav5, codret )
1881 cmdc
1882 cmd      endif
1883 cmdc
1884 cmd      if ( codret.eq.0 ) then
1885 cmdc
1886 cmd      call gmmod ( nccono//'.FamilMED',
1887 cmd     >             pfamee, nbele0, nbele1, un, un, codre1 )
1888 cmd      call gmmod ( nccono//'.Type',
1889 cmd     >             ptypel, nbele0, nbele1, un, un, codre2 )
1890 cmd      call gmmod ( nccono//'.Noeuds',
1891 cmd     >             pnoeel, nbele0, nbele1, nbmane, nbmane, codre3 )
1892 cmd      call gmecat ( nccono, 1, nbelem, codre4 )
1893 cmdc
1894 cmd      codre0 = min ( codre1, codre2, codre3, codre4 )
1895 cmd      codret = max ( abs(codre0), codret,
1896 cmd     >               codre1, codre2, codre3, codre4 )
1897 cmdc
1898 cmd      endif
1899 cmdc
1900 cmd      if ( codret.eq.0 ) then
1901 cmdc
1902 cmd#ifdef _DEBUG_HOMARD_
1903 cmd      write (ulsort,texte(langue,3)) 'PCMMEN', nompro
1904 cmd#endif
1905 cmd      call pcmmen ( nbele0, nbele1, nbtenw,
1906 cmd     >              imem(pnoeel), imem(pfamee), imem(ptypel),
1907 cmd     >              imem(adnumf),
1908 cmd     >              imem(adpoin), imem(adtail), smem(adtabl),
1909 cmd     >              imem(ptrav5), imem(ptrav5+2*nbfmed),
1910 cmd     >              ulsort, langue, codret )
1911 cmdc
1912 cmd      endif
1913 cmdc
1914 cmd      if ( codret.eq.0 ) then
1915 cmdc
1916 cmd      nbtetr = nbtetr + nbtenw
1917 cmd      nbelem = nbele0 + nbtenw
1918 cmdc
1919 cmd      call gmmod ( nccono//'.FamilMED',
1920 cmd     >             pfamee, nbele1, nbelem, un, un, codre1 )
1921 cmd      call gmmod ( nccono//'.Type',
1922 cmd     >             ptypel, nbele1, nbelem, un, un, codre2 )
1923 cmd      call gmmod ( nccono//'.Noeuds',
1924 cmd     >             pnoeel, nbele1, nbelem, nbmane, nbmane, codre3 )
1925 cmd      call gmecat ( nccono, 1, nbelem, codre4 )
1926 cmdc
1927 cmd      codre0 = min ( codre1, codre2, codre3, codre4 )
1928 cmd      codret = max ( abs(codre0), codret,
1929 cmd     >               codre1, codre2, codre3, codre4 )
1930 cmdc
1931 cmd      imem(adnbrp+15) = nbtetr
1932 cmd      imem(adnomb+6)  = nbtetr + nbhexa + nbpent + nbpyra
1933 cmd      imem(adnomb+14) = nbtetr
1934 cmdc
1935 cmd      endif
1936 cmdc
1937 cmd      if ( codret.eq.0 ) then
1938 cmdc
1939 cmd      call gmlboj ( ntrav5, codret )
1940 cmdc
1941 cmd      endif
1942 cmdc
1943 cmd      endif
1944 cmdc ---------------- MAILLES DOUBLES FIN ----------------
1945 c
1946 c====
1947 c 10. impression des nombres d'entites du maillage de calcul
1948 c====
1949 c
1950 #ifdef _DEBUG_HOMARD_
1951       write (ulsort,90002) '10. impression ; codret', codret
1952       call dmflsh(iaux)
1953 #endif
1954       if ( codret.eq.0 ) then
1955 c
1956       iaux = 0
1957       if ( langue.eq.1 ) then
1958 c                 12345678901234567890123456789012
1959         saux32 = 'apres conversion                '
1960       else
1961         saux32 = 'after the conversion            '
1962       endif
1963 #ifdef _DEBUG_HOMARD_
1964       write (ulsort,texte(langue,3)) 'UTINMA', nompro
1965 #endif
1966       call utinma ( iaux, saux32,
1967      >              sdimca, mdimca,  degre,
1968      >              nbnoto, nbnop1, nbnop2, nbnoim,
1969      >              nbnois, nbnomp,
1970      >              nbnoei, nbelem,
1971      >              nbmapo, nbsegm, nbtria, nbquad,
1972      >              nbtetr, nbhexa, nbpyra, nbpent,
1973      >              nbelig,
1974      >              nbmane, nbmaae, nbmafe,
1975      >              ulsort, langue, codret)
1976 c
1977       endif
1978 c
1979 c====
1980 c 11. sauvegarde des informations generales, au sens du module de
1981 c     calcul associe
1982 c     on peut faire des attachements car le maillage homard n'est
1983 c     jamais detruit.
1984 c====
1985 c
1986 #ifdef _DEBUG_HOMARD_
1987       write (ulsort,90002) '11. sauvegarde ; codret', codret
1988       call dmflsh(iaux)
1989 #endif
1990 c
1991 c 11.1. ==> a-t-on defini des informations en externe ?
1992 c
1993       if ( codret.eq.0 ) then
1994 c
1995       call gmobal ( nhsupe//'.Tab7', codret )
1996 c
1997       if ( codret.eq.0 ) then
1998         existe = .false.
1999       elseif ( codret.eq.2 ) then
2000         codret = 0
2001         existe = .true.
2002       else
2003         codret = 2
2004       endif
2005 c
2006       endif
2007 c
2008 c 11.2. ==> copie des differents attributs
2009 c
2010 #ifdef _DEBUG_HOMARD_
2011       write (ulsort,90002) '11.2. copie des attributs ; codret', codret
2012 #endif
2013 c
2014       if ( codret.eq.0 ) then
2015 c
2016       if ( existe ) then
2017 c
2018       if ( codret.eq.0 ) then
2019 c
2020       call gmliat ( nhsupe, 7, iaux , codre1 )
2021       call gmliat ( nhsups, 3,  jaux, codre2 )
2022 c
2023       codre0 = min ( codre1, codre2 )
2024       codret = max ( abs(codre0), codret,
2025      >               codre1, codre2 )
2026 c
2027       endif
2028 c
2029       if ( codret.eq.0 ) then
2030 c
2031       call gmecat ( ncinfo, 1, iaux , codre1 )
2032       call gmecat ( ncinfo, 2,  jaux, codre2 )
2033 c
2034       codre0 = min ( codre1, codre2 )
2035       codret = max ( abs(codre0), codret,
2036      >               codre1, codre2 )
2037 c
2038       endif
2039 c
2040       endif
2041
2042       endif
2043 c
2044 #ifdef _DEBUG_HOMARD_
2045       if ( codret.eq.0 ) then
2046 c
2047       call gmprsx (nompro//' 11.2', ncinfo )
2048       call gmprsx (nompro//' 11.2', ncinfo//'.Pointeur' )
2049       call gmprsx (nompro//' 11.2', ncinfo//'.Taille' )
2050       call gmprsx (nompro//' 11.2', ncinfo//'.Table' )
2051 c
2052       endif
2053 #endif
2054 c
2055 c 11.3. ==> copie des differentes branches
2056 c          attention : il faut faire des copies et non pas des
2057 c          attachements car le contenu est modifie ensuite dans
2058 c          certains cas
2059 #ifdef _DEBUG_HOMARD_
2060       write (ulsort,90002) '11.3. copie des branches ; codret', codret
2061 #endif
2062 c
2063       if ( codret.eq.0 ) then
2064 c
2065       if ( existe ) then
2066 c
2067       if ( codret.eq.0 ) then
2068 c
2069       call gmcpoj ( nhsupe//'.Tab7',
2070      >              ncinfo//'.Pointeur', codre1 )
2071       call gmcpoj ( nhsupe//'.Tab8',
2072      >              ncinfo//'.Taille', codre2 )
2073       call gmcpoj ( nhsups//'.Tab3',
2074      >              ncinfo//'.Table', codre3 )
2075 c
2076       codre0 = min ( codre1, codre2, codre3 )
2077       codret = max ( abs(codre0), codret,
2078      >               codre1, codre2, codre3 )
2079 c
2080       endif
2081 c
2082       if ( codret.eq.0 ) then
2083 c
2084       if ( mod(typcca-6,10).eq.0 ) then
2085 c
2086         call gmadoj ( ncinfo//'.Pointeur', pinfpt, iaux, codre1 )
2087         call gmadoj ( ncinfo//'.Table'   , pinftb, iaux, codre2 )
2088         call gmliat ( ncinfo, 1, iaux, codre3 )
2089         nbpqt = iaux - 1
2090 c
2091         codre0 = min ( codre1, codre2, codre3 )
2092         codret = max ( abs(codre0), codret,
2093      >                 codre1, codre2, codre3 )
2094 c
2095       endif
2096 c
2097 c 11.4. ==> changement du nom du maillage
2098 c
2099       if ( codret.eq.0 ) then
2100 c
2101       do 1114 , iaux = 1, nbpqt
2102 c
2103         jaux = pinftb + 10*(iaux-1)
2104 cgn        write (ulsort,90064) jaux, '%'//smem(jaux)//'%'
2105 c
2106 c 2.1. Repere et noms des coordonnees
2107 c
2108         if ( smem(jaux).eq.'NOMAMD  ' ) then
2109 c
2110           call utchs8 ( nomamd, lnomam, smem(jaux+1),
2111      >                  ulsort, langue, codret )
2112 c
2113         endif
2114 c
2115  1114 continue
2116 c
2117       endif
2118 c
2119       endif
2120 c
2121 #ifdef _DEBUG_HOMARD_
2122       if ( codret.eq.0 ) then
2123 c
2124       call gmprsx (nompro, ncinfo )
2125       call gmprsx (nompro, ncinfo//'.Pointeur' )
2126       call gmprsx (nompro, ncinfo//'.Taille' )
2127       call gmprsx (nompro, ncinfo//'.Table' )
2128 c
2129       endif
2130 #endif
2131 c
2132       endif
2133 c
2134       endif
2135 c
2136 c====
2137 c 12. Menage
2138 c====
2139 #ifdef _DEBUG_HOMARD_
2140       write (ulsort,90002) '12. Menage ; codret', codret
2141 #endif
2142 c
2143 c 12.1. ==> Structure dediee au deraffinement
2144 c
2145       if ( codret.eq.0 ) then
2146 c
2147       if ( deraff ) then
2148 c
2149       call gmlboj ( ntrav4, codret )
2150 c
2151       endif
2152 c
2153       endif
2154 c
2155 c 12.2. ==> Recuperation des sauvegardes dans le cas non conforme
2156 c
2157       if ( .not. cforme ) then
2158 c
2159 c 12.2.1. ==> Suppression des mailles temporaires dans les
2160 c             renumerotations
2161 c
2162         if ( codret.eq.0 ) then
2163 c
2164 cgn      call gmprsx (nompro,nospec//'.Tab1')
2165 cgn      call gmprsx (nompro,nospec//'.Tab3')
2166 cgn      call gmprsx (nompro,nospec//'.Tab5')
2167 c
2168 #ifdef _DEBUG_HOMARD_
2169         write (ulsort,texte(langue,3)) 'PCMAR1', nompro
2170 #endif
2171         call pcmar1 ( imem(adarcp),
2172      >                imem(adtrcp), imem(adqucp),
2173      >                imem(adtecp), imem(adhecp),
2174      >                imem(adpecp), imem(adpycp),
2175      >                nparrc, nptrrc, npqurc,
2176      >                imem(adarrc), imem(adtrrc), imem(adqurc),
2177      >                imem(adterc), imem(adherc),
2178      >                imem(adperc), imem(adpyrc),
2179      >                ulsort, langue, codret )
2180 c
2181         endif
2182 c
2183 cgn      call gmprsx (nompro,nospec)
2184 cgn      call gmprsx (nompro,nospec//'.Tab1')
2185 cgn      call gmprsx (nompro,nospec//'.Tab2')
2186 cgn      call gmprsx (nompro,nospec//'.Tab3')
2187 cgn      call gmprsx (nompro,nospec//'.Tab4')
2188 cgn      call gmprsx (nompro,nospec//'.Tab5')
2189 cgn      call gmprsx (nompro,nospec//'.Tab6')
2190 cgn      call gmprsx (nompro,nospec//'.Tab7')
2191 c
2192 c 12.2.2. ==> Recopie des historiques et familles
2193 c
2194 #ifdef _DEBUG_HOMARD_
2195       write (ulsort,90002) '12.2.2. Copie hist/fami - codret', codret
2196 #endif
2197 c
2198         if ( codret.eq.0 ) then
2199 c
2200         call gmcpoj ( ntrav1, nharet//'.HistEtat', codre1 )
2201         call gmlboj ( ntrav1, codre2 )
2202 c
2203         codre0 = min ( codre1, codre2 )
2204         codret = max ( abs(codre0), codret,
2205      >                 codre1, codre2 )
2206 c
2207         if ( nbtrto.ne.0 ) then
2208 c
2209           call gmcpoj ( ntrav2, nhtria//'.HistEtat', codre1 )
2210           call gmlboj ( ntrav2, codre2 )
2211 c
2212           codre0 = min ( codre1, codre2 )
2213           codret = max ( abs(codre0), codret,
2214      >                   codre1, codre2 )
2215 c
2216         endif
2217 c
2218         if ( nbquto.ne.0 ) then
2219 c
2220           call gmcpoj ( ntrav3, nhquad//'.HistEtat', codre1 )
2221           call gmlboj ( ntrav3, codre2 )
2222 c
2223           codre0 = min ( codre1, codre2 )
2224           codret = max ( abs(codre0), codret,
2225      >                   codre1, codre2 )
2226 c
2227         endif
2228 c
2229         endif
2230 c
2231       endif
2232 c
2233 c====
2234 c 13. la fin
2235 c====
2236 c
2237 #ifdef _DEBUG_HOMARD_
2238       write (ulsort,90002) '13. la fin ; codret', codret
2239       call dmflsh(iaux)
2240 #endif
2241 c
2242       if ( codret.ne.0 ) then
2243 c
2244 #include "envex2.h"
2245 c
2246       write (ulsort,texte(langue,1)) 'Sortie', nompro
2247       write (ulsort,texte(langue,2)) codret
2248       call gmprsx ( nompro , nhnoeu )
2249       if ( nbmapo.gt.0 ) then
2250         call gmprsx ( nompro , nhmapo )
2251       endif
2252       call gmprsx ( nompro , nharet )
2253       if ( nbtrto.gt.0 ) then
2254         call gmprsx ( nompro , nhtria )
2255       endif
2256       if ( nbquto.gt.0 ) then
2257         call gmprsx ( nompro , nhquad )
2258       endif
2259       if ( nbteto.gt.0 ) then
2260         call gmprsx ( nompro , nhtetr )
2261       endif
2262       if ( nbheto.gt.0 ) then
2263        call gmprsx ( nompro , nhhexa )
2264       endif
2265       if ( nbpyto.gt.0 ) then
2266         call gmprsx ( nompro , nhpyra )
2267       endif
2268       if ( nbpeto.gt.0 ) then
2269         call gmprsx ( nompro , nhpent )
2270       endif
2271 c
2272       endif
2273 c
2274 #ifdef _DEBUG_HOMARD_
2275       write (ulsort,texte(langue,1)) 'Sortie', nompro
2276       call dmflsh (iaux)
2277 #endif
2278 c
2279       end