src/tool/ES_MED/eslmm2.F

   1       subroutine eslmm2 ( idfmed, nomamd,
   2      >                    option,
   3      >                    titre,
   4      >                    degre, mailet, sdimca, nbmane, nbmail,
   5      >                    nbmapo, nbsegm, nbtria, nbtetr,
   6      >                    nbquad, nbhexa, nbpent, nbpyra,
   7      >                    nbfmed, nbfmen, ngrouc,
   8      >                    nbequi, nbeqno, nbeqmp, nbeqar,
   9      >                    nbeqtr, nbeqqu,
  10      >                    nbnoto, numano, numael,
  11      >                    nunoex, fameno, coonca,
  12      >                    numaex, fammai, noemai, typele,
  13      >                    grfmpo, grfmta, grfmtb,
  14      >                    nbpqt, infptr, inftll, inftbl,
  15      >                    typrep, nomaxe, uniaxe,
  16      >                    numfam, nomfam,
  17      >                    eqpntr, eqinfo,
  18      >                    eqnoeu,
  19      >                    eqmapo, eqaret, eqtria, eqquad,
  20      >                    tabaux,
  21      >                    ulsort, langue, codret )
  22 c ______________________________________________________________________
  23 c
  24 c                             H O M A R D
  25 c
  26 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  27 c
  28 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  29 c aupres des huissiers de justice Simart et Lavoir a Clamart
  30 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  31 c aupres des huissiers de justice
  32 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  33 c
  34 c    HOMARD est une marque deposee d'Electricite de France
  35 c
  36 c Copyright EDF 1996
  37 c Copyright EDF 1998
  38 c Copyright EDF 2002
  39 c Copyright EDF 2020
  40 c ______________________________________________________________________
  41 c
  42 c  Entree-Sortie - Lecture du Maillage au format MED - phase 2
  43 c  -      -        -          -                  -           -
  44 c remarque : on s'arrange pour que les mailles externes soient
  45 c            numerotees dans cet ordre :
  46 c            . les tetraedres
  47 c            . les triangles
  48 c            . les aretes
  49 c            . les mailles-points
  50 c            . les quadrangles
  51 c            . les hexaedres
  52 c            . les pyramides
  53 c            . les pentaedres
  54 c ______________________________________________________________________
  55 c .        .     .        .                                            .
  56 c .  nom   . e/s . taille .           description                      .
  57 c .____________________________________________________________________.
  58 c . idfmed . e   .   1    . unite logique du maillage d'entree         .
  59 c . nomamd . e   . char64 . nom du maillage MED                        .
  60 c . option . e   .    1   . option de lecture du maillage              .
  61 c .        .     .        . 1 : lecture integrale                      .
  62 c .        .     .        . 2 : uniquement les coordonnees des noeuds  .
  63 c . fameno .  s  . nbnoto . famille med des noeuds                     .
  64 c . coonca .  s  . nbnoto . coordonnees des noeuds                     .
  65 c . fammai .  s  . nbmail . famille med des mailles                    .
  66 c . noemai .  s  . nbmail*. table de connectivite des mailles          .
  67 c .        .     . nbmane .                                            .
  68 c . numaex .  s  . nbmail . numerotation des mailles en entree         .
  69 c . nunoex .  s  . nbnoto . numerotation des noeuds en entree          .
  70 c .        .     .        .                                            .
  71 c . grfmpo .  s  .nbfmed+1. pointeur des groupes des familles          .
  72 c . grfmta .  s  .10ngrouc. taille des groupes des familles            .
  73 c . grfmtb .  s  .10ngrouc. table des groupes des familles             .
  74 c . nbpqt  .  e  .    1   . nombre de paquets des infos generales      .
  75 c . infptr .  s  . nbpqt+1. pointeur des informations generales        .
  76 c . inftll .  s  .nbpqt*10. tailles des caracteres des infos generales.
  77 c . inftbl .  s  .nbpqt*10. tables en caracteres des infos generales   .
  78 c .        .     .        . regroupees par paquets de 80 caracteres    .
  79 c .        .     .        . pour gerer la conversion en pseudo-groupe  .
  80 c .        .     .        . paquet 1 : 1 : 'NomCo'                       .
  81 c .        .     .        .            2/3, 4/5, 6/7 : nom coordonnees .
  82 c .        .     .        .            8 : nom du repere utilise       .
  83 c .        .     .        . paquet 2 : 1 : 'UniteCo'                     .
  84 c .        .     .        .            2/3, 4/5, 6/7 : unite coord.    .
  85 c .        .     .        . paquet 3 : titre (limite a 80 caracteres)  .
  86 c .        .     .        . paquet 4 : 1 : 'NOMAMD'                    .
  87 c .        .     .        .            2-7 : nom du maillage           .
  88 c . typrep . e   .   1    . type de repere                             .
  89 c . nomaxe . e   .   3    . nom des axes de coordonnees                .
  90 c . uniaxe . e   .   3    . unite des axes de coordonnees              .
  91 c . numfam .  s  . nbfmed . numero des familles                        .
  92 c . nomfam .  s  .10nbfmed. nom des familles                           .
  93 c . numfam .  s  . nbfmed . numero des familles                        .
  94 c . eqpntr .  s  .5*nbequi. 5i-4 : nombre de paires de noeuds pour     .
  95 c .        .     .        .        l'equivalence i                     .
  96 c .        .     .        . 5i-3 : idem pour les mailles-points        .
  97 c .        .     .        . 5i-2 : idem pour les aretes                .
  98 c .        .     .        . 5i-1 : idem pour les triangles             .
  99 c .        .     .        . 5i   : idem pour les quadrangles           .
 100 c . eqinfo .  s  .33nbequi. nom et description de chaque equivalence   .
 101 c . eqnoeu .  s  .2*nbeqno. liste des paires de noeuds equivalents avec.
 102 c .        .     .        . la convention : eqnoeu(i)<-->eqnoeu(i+1)   .
 103 c . eqmapo .  s  .2*nbeqmp. idem pour les points                       .
 104 c . eqaret .  s  .2*nbeqar. idem pour les aretes                       .
 105 c . eqtria .  s  .2*nbeqtr. idem pour les triangles                    .
 106 c . eqquad .  s  .2*nbeqqu. idem pour les quadrangles                  .
 107 c . tabaux .  a  .   *    . tableau auxiliaire entier                  .
 108 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 109 c . langue . e   .    1   . langue des messages                        .
 110 c .        .     .        . 1 : francais, 2 : anglais                  .
 111 c . codret . es  .    1   . code de retour des modules                 .
 112 c .        .     .        . 0 : pas de probleme                        .
 113 c .        .     .        . 1 : probleme                               .
 114 c ______________________________________________________________________
 115 c
 116 c====
 117 c 0. declarations et dimensionnement
 118 c====
 119 c
 120 c 0.1. ==> generalites
 121 c
 122       implicit none
 123       save
 124 c
 125       character*6 nompro
 126       parameter ( nompro = 'ESLMM2' )
 127 c
 128 #include "nblang.h"
 129 #include "consts.h"
 130 c
 131 c 0.2. ==> communs
 132 c
 133 #include "envex1.h"
 134 c
 135 c 0.3. ==> arguments
 136 c
 137       integer option
 138 c
 139       integer         degre, mailet, sdimca, nbmane
 140       integer         nbmail,
 141      >                nbmapo, nbsegm, nbtria, nbtetr,
 142      >                nbquad, nbhexa, nbpent, nbpyra,
 143      >                nbfmed, nbfmen, ngrouc,
 144      >                nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu
 145       integer         nbnoto
 146       integer  numano, numael
 147 c
 148       integer fameno(nbnoto)
 149       integer fammai(nbmail), typele(nbmail)
 150       integer numaex(nbmail), nunoex(nbnoto)
 151       integer noemai(nbmail,nbmane)
 152       integer*8 idfmed
 153       integer grfmpo(0:nbfmed), grfmta(10*ngrouc)
 154       integer numfam(nbfmed)
 155       integer nbpqt
 156       integer infptr(0:nbpqt), inftll(10*nbpqt)
 157       integer eqpntr(5*nbequi)
 158       integer eqnoeu(2*nbeqno)
 159       integer eqmapo(2*nbeqmp), eqaret(2*nbeqar)
 160       integer eqtria(2*nbeqtr), eqquad(2*nbeqqu)
 161       integer tabaux(*)
 162       integer typrep
 163 c
 164       character*8 saux08
 165       character*8 grfmtb(10*ngrouc)
 166       character*8 inftbl(10*nbpqt)
 167       character*8 nomfam(10,nbfmed)
 168       character*8 eqinfo(33*nbequi)
 169       character*16 nomaxe(3), uniaxe(3)
 170       character*64 nomamd
 171       character*(*) titre
 172 c
 173       double precision coonca(nbnoto,sdimca)
 174 c
 175       integer ulsort, langue, codret
 176 c
 177 c 0.4. ==> variables locales
 178 c
 179 #include "meddc0.h"
 180 c
 181       integer nummai
 182       integer iaux, jaux, kaux, laux, maux
 183       integer typnoe, typpoi, typseg, typtri, typtet
 184       integer typqua, typhex, typpyr, typpen
 185       integer ibtetr, ibtria, ibsegm, ibmapo
 186       integer ibquad, ibhexa, ibpyra, ibpent
 187       integer codre1, codre2
 188       integer codre0
 189       integer numero, ngro
 190       integer adeqin, adeqno, adeqmp, adeqar, adeqtr, adeqqu
 191       integer numdt, numit
 192       integer nstep, nctcor
 193 c
 194       character*64 saux64
 195       character*200 sau200
 196 c
 197       integer nbmess
 198       parameter ( nbmess = 10 )
 199       character*80 texte(nblang,nbmess)
 200 c ______________________________________________________________________
 201
 202 c
 203 c====
 204 c 1. initialisations
 205 c====
 206 c
 207 #include "impr01.h"
 208 c
 209 #ifdef _DEBUG_HOMARD_
 210       write (ulsort,texte(langue,1)) 'Entree', nompro
 211       call dmflsh (iaux)
 212 #endif
 213 c
 214       texte(1,4) = '(/,''REPERE NON PREVU ='',i4,/)'
 215 c
 216       texte(2,4) = '(/,''REPERE NON PREVU ='',i4,/)'
 217 c
 218 #include "impr03.h"
 219 c
 220 #ifdef _DEBUG_HOMARD_
 221       write (ulsort,90002) 'option', option
 222 #endif
 223 c
 224       numdt = ednodt
 225       numit = ednoit
 226 c
 227 c====
 228 c 2. grandeurs de base
 229 c====
 230 c
 231       typnoe = 0
 232       typpoi = edpoi1
 233       if ( degre.eq.1 ) then
 234         typseg = edseg2
 235         typtri = edtri3
 236         typtet = edtet4
 237         typqua = edqua4
 238         typhex = edhex8
 239         typpyr = edpyr5
 240         typpen = edpen6
 241       else
 242         typseg = edseg3
 243         if ( mod(mailet,2).eq.0 ) then
 244           typtri = edtri7
 245         else
 246           typtri = edtri6
 247         endif
 248         typtet = edte10
 249         if ( mod(mailet,3).eq.0 ) then
 250           typqua = edqua9
 251         else
 252           typqua = edqua8
 253         endif
 254         if ( mod(mailet,5).eq.0 ) then
 255           typhex = edhe27
 256         else
 257           typhex = edhe20
 258         endif
 259         typpyr = edpy13
 260         typpen = edpe15
 261       endif
 262 c
 263       ibtetr = 1
 264       ibtria = nbtetr + 1
 265       ibsegm = nbtetr + nbtria + 1
 266       ibmapo = nbtetr + nbtria + nbsegm + 1
 267       ibquad = nbtetr + nbtria + nbsegm + nbmapo + 1
 268       ibhexa = nbtetr + nbtria + nbsegm + nbmapo + nbquad + 1
 269       ibpyra = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + 1
 270       ibpent = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
 271      >       + nbpyra + 1
 272 c
 273 c====
 274 c 4. les coordonnees des noeuds
 275 c    le tableau coonca est declare ainsi : coonca(nbnoto,sdimca).
 276 c    En fortran, cela correspond au stockage memoire suivant :
 277 c    coonca(1,1), coonca(2,1), coonca(3,1), ..., coonca(nbnoto,1),
 278 c    coonca(1,2), coonca(2,2), coonca(3,2), ..., coonca(nbnoto,2),
 279 c    ...
 280 c    coonca(1,sdimca), coonca(2,sdimca), ..., coonca(nbnoto,sdimca)
 281 c    on a ainsi toutes les abscisses, puis toutes les ordonnees, etc.
 282 c    C'est ce que MED appelle le mode non entrelace.
 283 c====
 284 #ifdef _DEBUG_HOMARD_
 285       write (ulsort,90002) '4. coordonnees ; codret', codret
 286 #endif
 287 c
 288 c 4.1. ==> lecture
 289 c
 290       if ( codret.eq.0 ) then
 291 c
 292 #ifdef _DEBUG_HOMARD_
 293       write (ulsort,texte(langue,3)) 'ESLMNO', nompro
 294 #endif
 295       call eslmno ( idfmed, nomamd,
 296      >              option,
 297      >              nbnoto, sdimca, coonca, fameno,
 298      >              ulsort, langue, codret )
 299 c
 300       endif
 301 c
 302 c 4.2. ==> archivages des informations generales
 303 c            Remarque : elles sont regroupees par paquets de
 304 c                       80 caracteres pour  gerer la conversion en
 305 c                       pseudo-groupe dans hom.med
 306 c            . paquet 1 : 1 : 'NomCo'
 307 c                         2/3, 4/5, 6/7 : nom coordonnees
 308 c                         8 : nom du repere utilise
 309 c            . paquet 2 : 1 : 'UniteCo'
 310 c                         2/3, 4/5, 6/7 : unite coordonnees
 311 c            . paquet 3 : titre (limite a 80 caracteres)
 312 c            . paquet 4 : 1 : 'NOMAMD'
 313 c                         2-7 : nom du maillage
 314 #ifdef _DEBUG_HOMARD_
 315       write (ulsort,90002) '4.2. ; codret', codret
 316 #endif
 317 c
 318       if ( option.eq.1 ) then
 319 c
 320 c 4.2.1. ==> la base
 321 c
 322       infptr(0) = 0
 323       do 4211 , iaux = 1, nbpqt
 324         infptr(iaux) = infptr(iaux-1) + 10
 325  4211 continue
 326 c
 327       do 4212 , iaux = 1, 10*nbpqt
 328         inftll(iaux) = 8
 329         inftbl(iaux) = blan08
 330  4212 continue
 331 c
 332 c 4.2.2. ==> le systeme de coordonnees
 333 c
 334 c 4.2.2.1. ==> le type de repere
 335 c
 336       if ( codret.eq.0 ) then
 337 c
 338       call utench ( typrep, 'd', iaux, saux08,
 339      >              ulsort, langue, codret )
 340 c
 341       inftbl(10) = saux08
 342 c
 343       endif
 344 c
 345 c 4.2.2.2. ==> noms et unites des coordonnees existantes
 346 c
 347       if ( codret.eq.0 ) then
 348 c
 349       inftbl( 1) = 'NomCo   '
 350       inftbl(11) = 'UniteCo '
 351 c
 352       do 4222 , iaux = 1 , sdimca
 353 c
 354 cgn        write (ulsort,90064) iaux, 'nomaxe %'//nomaxe(iaux)//'%'
 355         inftbl(2*iaux) = nomaxe(iaux)(1:8)
 356         inftbl(2*iaux+1) = nomaxe(iaux)(9:16)
 357 c
 358 cgn        write (ulsort,90064) iaux, 'uniaxe %'//uniaxe(iaux)//'%'
 359         inftbl(10+2*iaux) = uniaxe(iaux)(1:8)
 360         inftbl(11+2*iaux) = uniaxe(iaux)(9:16)
 361 c
 362  4222 continue
 363 c
 364       endif
 365 c
 366 c 4.2.3. ==> le titre
 367 #ifdef _DEBUG_HOMARD_
 368       write (ulsort,90002) '4.2.3. ; codret', codret
 369 #endif
 370 c
 371       if ( codret.eq.0 ) then
 372 c
 373       iaux = len(titre)
 374       call utchs8 ( titre, iaux, inftbl(21),
 375      >              ulsort, langue, codret )
 376 c
 377       endif
 378 c
 379 c 4.2.4. ==> le nom du maillage
 380 #ifdef _DEBUG_HOMARD_
 381       write (ulsort,90002) '4.2.4. ; codret', codret
 382 #endif
 383 c
 384       if ( codret.eq.0 ) then
 385 c
 386       inftbl(31) = 'NOMAMD  '
 387       iaux = len(nomamd)
 388       call utchs8 ( nomamd, iaux, inftbl(32),
 389      >              ulsort, langue, codret )
 390 c
 391       endif
 392 c
 393       endif
 394 c
 395 c====
 396 c 5. Les mailles
 397 c====
 398 c
 399 #ifdef _DEBUG_HOMARD_
 400       write (ulsort,90002) '5. mailles ; codret', codret
 401 #endif
 402 c
 403       if ( option.eq.1 ) then
 404 c
 405       kaux = 1
 406 c
 407 c 5.1. ==> les tetraedres
 408 c
 409       if ( codret.eq.0 ) then
 410 c
 411       if ( nbtetr.gt.0 ) then
 412 c
 413         iaux = 3
 414         if ( degre.eq.1 ) then
 415           jaux = 4
 416         else
 417           jaux = 10
 418         endif
 419 #ifdef _DEBUG_HOMARD_
 420       write (ulsort,texte(langue,3)) 'ESLMMB_te', nompro
 421 #endif
 422         call eslmmb ( idfmed, nomamd,
 423      >                iaux, edmail, typtet,
 424      >                ibtetr, nbtetr, jaux, nbmail, kaux,
 425      >                ednoda, nbmail,
 426      >                noemai, fammai,
 427      >                tabaux,
 428      >                ulsort, langue, codret )
 429 c
 430       endif
 431 c
 432       endif
 433 c
 434 c 5.2. ==> les triangles
 435 c
 436       if ( codret.eq.0 ) then
 437 c
 438       if ( nbtria.gt.0 ) then
 439 c
 440         iaux = 2
 441         if ( degre.eq.1 ) then
 442           jaux = 3
 443         else
 444           if ( mod(mailet,2).eq.0 ) then
 445             jaux = 7
 446           else
 447             jaux = 6
 448           endif
 449         endif
 450 #ifdef _DEBUG_HOMARD_
 451       write (ulsort,texte(langue,3)) 'ESLMMB_tr', nompro
 452 #endif
 453         call eslmmb ( idfmed, nomamd,
 454      >                iaux, edmail, typtri,
 455      >                ibtria, nbtria, jaux, nbmail, kaux,
 456      >                ednoda, nbmail,
 457      >                noemai, fammai,
 458      >                tabaux,
 459      >                ulsort, langue, codret )
 460 c
 461       endif
 462 c
 463       endif
 464 c
 465 c 5.3. ==> les segments
 466 c
 467       if ( codret.eq.0 ) then
 468 c
 469       if ( nbsegm.gt.0 ) then
 470 c
 471         iaux = 1
 472         if ( degre.eq.1 ) then
 473           jaux = 2
 474         else
 475           jaux = 3
 476         endif
 477 #ifdef _DEBUG_HOMARD_
 478       write (ulsort,texte(langue,3)) 'ESLMMB_se', nompro
 479 #endif
 480         call eslmmb ( idfmed, nomamd,
 481      >                iaux, edmail, typseg,
 482      >                ibsegm, nbsegm, jaux, nbmail, kaux,
 483      >                ednoda, nbmail,
 484      >                noemai, fammai,
 485      >                tabaux,
 486      >                ulsort, langue, codret )
 487 c
 488       endif
 489 c
 490       endif
 491 c
 492 c 5.4. ==> les mailles points
 493 c
 494       if ( codret.eq.0 ) then
 495 c
 496       if ( nbmapo.gt.0 ) then
 497 c
 498         iaux = 0
 499         jaux = 1
 500 #ifdef _DEBUG_HOMARD_
 501       write (ulsort,texte(langue,3)) 'ESLMMB_mp', nompro
 502 #endif
 503         call eslmmb ( idfmed, nomamd,
 504      >                iaux, edmail, typpoi,
 505      >                ibmapo, nbmapo, jaux, nbmail, kaux,
 506      >                ednoda, nbmail,
 507      >                noemai, fammai,
 508      >                tabaux,
 509      >                ulsort, langue, codret )
 510 c
 511       endif
 512 c
 513       endif
 514
 515 c
 516 c 5.5. ==> les quadrangles
 517 c
 518       if ( codret.eq.0 ) then
 519 c
 520       if ( nbquad.gt.0 ) then
 521 c
 522         iaux = 4
 523         if ( degre.eq.1 ) then
 524           jaux = 4
 525         else
 526           if ( mod(mailet,3).eq.0 ) then
 527             jaux = 9
 528           else
 529             jaux = 8
 530           endif
 531         endif
 532 #ifdef _DEBUG_HOMARD_
 533       write (ulsort,texte(langue,3)) 'ESLMMB_qu', nompro
 534 #endif
 535         call eslmmb ( idfmed, nomamd,
 536      >                iaux, edmail, typqua,
 537      >                ibquad, nbquad, jaux, nbmail, kaux,
 538      >                ednoda, nbmail,
 539      >                noemai, fammai,
 540      >                tabaux,
 541      >                ulsort, langue, codret )
 542 c
 543       endif
 544 c
 545       endif
 546 c
 547 c 5.6. ==> les pyramides
 548 c
 549       if ( codret.eq.0 ) then
 550 c
 551       if ( nbpyra.gt.0 ) then
 552 c
 553         iaux = 5
 554         if ( degre.eq.1 ) then
 555           jaux = 5
 556         else
 557           jaux = 13
 558         endif
 559 #ifdef _DEBUG_HOMARD_
 560       write (ulsort,texte(langue,3)) 'ESLMMB_py', nompro
 561 #endif
 562         call eslmmb ( idfmed, nomamd,
 563      >                iaux, edmail, typpyr,
 564      >                ibpyra, nbpyra, jaux, nbmail, kaux,
 565      >                ednoda, nbmail,
 566      >                noemai, fammai,
 567      >                tabaux,
 568      >                ulsort, langue, codret )
 569 c
 570       endif
 571 c
 572       endif
 573 c
 574 c 5.7. ==> les hexaedres
 575 c
 576       if ( codret.eq.0 ) then
 577 c
 578       if ( nbhexa.gt.0 ) then
 579 c
 580         iaux = 6
 581         if ( degre.eq.1 ) then
 582           jaux = 8
 583         else
 584           if ( mod(mailet,3).eq.0 ) then
 585             jaux = 27
 586           else
 587             jaux = 20
 588           endif
 589         endif
 590 #ifdef _DEBUG_HOMARD_
 591       write (ulsort,texte(langue,3)) 'ESLMMB_he', nompro
 592 #endif
 593         call eslmmb ( idfmed, nomamd,
 594      >                iaux, edmail, typhex,
 595      >                ibhexa, nbhexa, jaux, nbmail, kaux,
 596      >                ednoda, nbmail,
 597      >                noemai, fammai,
 598      >                tabaux,
 599      >                ulsort, langue, codret )
 600 c
 601       endif
 602 c
 603       endif
 604 c
 605 c 5.8. ==> les pentaedres
 606 c
 607       if ( codret.eq.0 ) then
 608 c
 609       if ( nbpent.gt.0 ) then
 610 c
 611         iaux = 7
 612         if ( degre.eq.1 ) then
 613           jaux = 6
 614         else
 615           jaux = 15
 616         endif
 617 #ifdef _DEBUG_HOMARD_
 618       write (ulsort,texte(langue,3)) 'ESLMMB_pe', nompro
 619 #endif
 620         call eslmmb ( idfmed, nomamd,
 621      >                iaux, edmail, typpen,
 622      >                ibpent, nbpent, jaux, nbmail, kaux,
 623      >                ednoda, nbmail,
 624      >                noemai, fammai,
 625      >                tabaux,
 626      >                ulsort, langue, codret )
 627 c
 628       endif
 629 c
 630       endif
 631 c
 632       endif
 633 c
 634 c====
 635 c 6. les familles
 636 c====
 637 #ifdef _DEBUG_HOMARD_
 638       write (ulsort,90002) '6. Familles ; codret', codret
 639 #endif
 640 c
 641       if ( option.eq.1 ) then
 642 c
 643       if ( codret.eq.0 ) then
 644 c
 645       grfmpo(0) = 0
 646       nbfmen = 0
 647 c
 648       do 60 , jaux = 1, nbfmed
 649 c
 650         if ( codret.eq.0 ) then
 651 c
 652 c 6.1. ==> Lecture du nombre de groupes
 653 c
 654         iaux = jaux
 655 c
 656 #ifdef _DEBUG_HOMARD_
 657         write (ulsort,texte(langue,3)) 'MFANFG', nompro
 658 #endif
 659         call mfanfg ( idfmed, nomamd, iaux, ngro, codre1 )
 660 c
 661         grfmpo(jaux) = grfmpo(iaux-1) + ngro*10
 662 c
 663 c 6.2. ==> Lecture :
 664 c          . du nom de la famille (64)
 665 c          . du numero de la famille
 666 c          . des noms des groupes (80)
 667 c
 668 #ifdef _DEBUG_HOMARD_
 669         write (ulsort,texte(langue,3)) 'MFAFAI', nompro
 670 #endif
 671         call mfafai ( idfmed, nomamd, iaux,
 672      >                saux64, numero, grfmtb(grfmpo(iaux-1)+1),
 673      >                codre2 )
 674 c
 675         codre0 = min ( codre1, codre2 )
 676         codret = max ( abs(codre0), codret,
 677      >                 codre1, codre2 )
 678 c
 679         endif
 680 c
 681 c 6.3. ==> Stockage de la taille reelle des noms des groupes
 682 c
 683         if ( codret.eq.0 ) then
 684 c
 685         do 63 , kaux = 1 , ngro
 686 c
 687           do 631 , maux = 1 , 10
 688             call utlgut ( laux, grfmtb(grfmpo(iaux-1)+10*(kaux-1)+maux),
 689      >                    ulsort, langue, codret )
 690             grfmta(grfmpo(iaux-1)+10*(kaux-1)+maux) = laux
 691   631   continue
 692 c
 693    63   continue
 694 c
 695 c 6.4. ==> Stockage du numero et du nom de la famille
 696 c          Attention : on stocke sur 80 caracteres pour le futur
 697 c          archivage HOM-MED
 698 c
 699         if ( numero.gt.0 ) then
 700           nbfmen = nbfmen + 1
 701         endif
 702 c
 703         numfam(iaux) = numero
 704 c
 705         call utlgut ( laux, saux64,
 706      >                ulsort, langue, codret )
 707 c
 708         do 64 , kaux = laux+1 , 64
 709           saux64(kaux:kaux) = ' '
 710    64   continue
 711 c
 712         nomfam(1,jaux) = saux64( 1: 8)
 713         nomfam(2,jaux) = saux64( 9:16)
 714         nomfam(3,jaux) = saux64(17:24)
 715         nomfam(4,jaux) = saux64(25:32)
 716         nomfam(5,jaux) = saux64(33:40)
 717         nomfam(6,jaux) = saux64(41:48)
 718         nomfam(7,jaux) = saux64(49:56)
 719         nomfam(8,jaux) = saux64(57:64)
 720 c
 721         endif
 722 c
 723    60 continue
 724 c
 725       endif
 726 c
 727 #ifdef _DEBUG_HOMARD_
 728 c 6.9. ==> impressions
 729 c
 730       if ( codret.eq.0 ) then
 731 c
 732       do 69 , iaux = 1, nbfmed
 733 c
 734         if ( codret.eq.0 ) then
 735 c
 736         numero = numfam(iaux)
 737 c
 738         ngro = ( grfmpo(iaux) - grfmpo(iaux-1) ) / 10
 739 c
 740         saux64( 1: 8) = nomfam(1,iaux)
 741         saux64( 9:16) = nomfam(2,iaux)
 742         saux64(17:24) = nomfam(3,iaux)
 743         saux64(25:32) = nomfam(4,iaux)
 744         saux64(33:40) = nomfam(5,iaux)
 745         saux64(41:48) = nomfam(6,iaux)
 746         saux64(49:56) = nomfam(7,iaux)
 747         saux64(57:64) = nomfam(8,iaux)
 748 c
 749         jaux = 0
 750         do 692 , nummai = 1 , nbnoto
 751           if ( fameno(nummai).eq.numero ) then
 752             jaux = jaux + 1
 753           endif
 754   692   continue
 755 c
 756         kaux = 0
 757         do 693 , nummai = 1 , nbmail
 758           if ( fammai(nummai).eq.numero ) then
 759             kaux = kaux + 1
 760           endif
 761   693   continue
 762 c
 763         call utinfm ( numero, saux64,
 764      >                ngro, grfmtb(grfmpo(iaux-1)+1),
 765      >                jaux, kaux,
 766      >                ulsort, langue, codret )
 767 c
 768         endif
 769 c
 770    69 continue
 771 c
 772       endif
 773 c
 774 #endif
 775 c
 776       endif
 777 c
 778 c====
 779 c 7. les renumerotations
 780 c====
 781 c
 782 #ifdef _DEBUG_HOMARD_
 783       write (ulsort,90002) '7. renumerotations ; codret', codret
 784 #endif
 785 c
 786       if ( option.eq.1 ) then
 787 c
 788       if ( codret.eq.0 ) then
 789 c
 790 #ifdef _DEBUG_HOMARD_
 791       write (ulsort,texte(langue,3)) 'ESLNUM', nompro
 792 #endif
 793       call eslnum ( idfmed, nomamd, degre,
 794      >              nbnoto, nbmail,
 795      >              nbmapo, nbsegm, nbtria, nbtetr,
 796      >              nbquad, nbhexa, nbpent, nbpyra,
 797      >              nunoex, numaex,
 798      >              numano, numael,
 799      >              ulsort, langue, codret )
 800 c
 801       endif
 802 c
 803       endif
 804 c
 805 c====
 806 c 8. equivalences
 807 c    la convention de stockage MED des listes d'equivalences est que
 808 c    l'entite Liste(j) est associee a Liste(j+1)
 809 c====
 810 c
 811 #ifdef _DEBUG_HOMARD_
 812       write (ulsort,90002) '8. equivalences ; codret', codret
 813 #endif
 814 c
 815       if ( option.eq.1 ) then
 816 c
 817       if ( codret.eq.0 ) then
 818 c
 819       adeqin = 1
 820       adeqno = 1
 821       adeqmp = 1
 822       adeqar = 1
 823       adeqtr = 1
 824       adeqqu = 1
 825 c
 826 c     par defaut, on n'a aucune equivalence
 827 c
 828       jaux = 5*nbequi
 829       do 80 , iaux = 1, jaux
 830         eqpntr(iaux) = 0
 831    80 continue
 832 c
 833       do 81 , iaux = 1, nbequi
 834 c
 835 c 8.1. ==> nom et description de l'equivalence numero iaux
 836 c
 837         if ( codret.eq.0 ) then
 838 c
 839 #ifdef _DEBUG_HOMARD_
 840       write (ulsort,texte(langue,3)) 'MEQEQI', nompro
 841 #endif
 842         call meqeqi ( idfmed, nomamd, iaux,
 843      >                saux64, sau200, nstep, nctcor, codret )
 844 c
 845         endif
 846 c
 847         if ( codret.eq.0 ) then
 848 c
 849         kaux = 8
 850         jaux = 8
 851         call utchs8 ( saux64, jaux*kaux, eqinfo(adeqin),
 852      >                ulsort, langue, codret )
 853         adeqin = adeqin + jaux
 854 c
 855         endif
 856 c
 857         if ( codret.eq.0 ) then
 858 c
 859         jaux = 25
 860         call utchs8 ( sau200, jaux*kaux, eqinfo(adeqin),
 861      >                ulsort, langue, codret )
 862         adeqin = adeqin + jaux
 863 c
 864         endif
 865 c
 866 c 8.2. ==> equivalence de noeuds
 867 c
 868         if ( codret.eq.0 ) then
 869 #ifdef _DEBUG_HOMARD_
 870         write (ulsort,texte(langue,3)) 'MEQCSZ_no', nompro
 871 #endif
 872         call meqcsz ( idfmed, nomamd, saux64, numdt, numit,
 873      >                ednoeu, typnoe,
 874      >                jaux, codret )
 875         endif
 876 c
 877         if ( jaux.ne.0 ) then
 878 c
 879           if ( codret.eq.0 ) then
 880 #ifdef _DEBUG_HOMARD_
 881         write (ulsort,texte(langue,3)) 'MEQCOR_no', nompro
 882 #endif
 883           call meqcor ( idfmed, nomamd, saux64, numdt, numit,
 884      >                  ednoeu, typnoe,
 885      >                  eqnoeu(adeqno), codret )
 886           endif
 887 c
 888           eqpntr(5*iaux-4) = jaux
 889           adeqno = adeqno + 2*jaux
 890 c
 891         endif
 892 c
 893 c 8.3. ==> equivalence de mailles-points
 894 c
 895         if ( nbmapo.ne.0 ) then
 896 c
 897           if ( codret.eq.0 ) then
 898 #ifdef _DEBUG_HOMARD_
 899         write (ulsort,texte(langue,3)) 'MEQCSZ_mp', nompro
 900 #endif
 901           call meqcsz ( idfmed, nomamd, saux64, numdt, numit,
 902      >                  edmail, typpoi,
 903      >                  jaux, codret )
 904           endif
 905 c
 906           if ( jaux.ne.0 ) then
 907 c
 908             if ( codret.eq.0 ) then
 909             call meqcor ( idfmed, nomamd, saux64, numdt, numit,
 910      >                    edmail, typpoi,
 911      >                    eqmapo(adeqmp), codret )
 912             endif
 913 c
 914             eqpntr(5*iaux-3) = jaux
 915             adeqmp = adeqmp + 2*jaux
 916 c
 917           endif
 918 c
 919         endif
 920 c
 921 c 8.4. ==> equivalence de segments
 922 c
 923         if ( nbsegm.ne.0 ) then
 924 c
 925           if ( codret.eq.0 ) then
 926 #ifdef _DEBUG_HOMARD_
 927         write (ulsort,texte(langue,3)) 'MEQCSZ_ar', nompro
 928 #endif
 929           call meqcsz ( idfmed, nomamd, saux64, numdt, numit,
 930      >                  edmail, typseg,
 931      >                  jaux, codret )
 932           endif
 933 c
 934           if ( jaux.ne.0 ) then
 935 c
 936             if ( codret.eq.0 ) then
 937             call meqcor ( idfmed, nomamd, saux64, numdt, numit,
 938      >                    edmail, typseg,
 939      >                    eqaret(adeqar), codret )
 940             endif
 941 c
 942             eqpntr(5*iaux-2) = jaux
 943             adeqar = adeqar + 2*jaux
 944 c
 945           endif
 946 c
 947         endif
 948 c
 949 c 8.5. ==> equivalence de triangles
 950 c
 951         if ( nbtria.ne.0 ) then
 952 c
 953           if ( codret.eq.0 ) then
 954 #ifdef _DEBUG_HOMARD_
 955         write (ulsort,texte(langue,3)) 'MEQCSZ_tr', nompro
 956 #endif
 957           call meqcsz ( idfmed, nomamd, saux64, numdt, numit,
 958      >                  edmail, typtri,
 959      >                  jaux, codret )
 960           endif
 961 c
 962           if ( jaux.ne.0 ) then
 963 c
 964             if ( codret.eq.0 ) then
 965             call meqcor ( idfmed, nomamd, saux64, numdt, numit,
 966      >                    edmail, typtri,
 967      >                    eqtria(adeqtr), codret )
 968             endif
 969 c
 970             eqpntr(5*iaux-1) = jaux
 971             adeqtr = adeqtr + 2*jaux
 972 c
 973           endif
 974 c
 975         endif
 976 c
 977 c 8.6. ==> equivalence de quadrangles
 978 c
 979         if ( nbquad.ne.0 ) then
 980 c
 981           if ( codret.eq.0 ) then
 982 #ifdef _DEBUG_HOMARD_
 983         write (ulsort,texte(langue,3)) 'MEQCSZ_qu', nompro
 984 #endif
 985           call meqcsz ( idfmed, nomamd, saux64, numdt, numit,
 986      >                  edmail, typqua,
 987      >                  jaux, codret )
 988           endif
 989 c
 990           if ( jaux.ne.0 ) then
 991 c
 992             if ( codret.eq.0 ) then
 993             call meqcor ( idfmed, nomamd, saux64, numdt, numit,
 994      >                    edmail, typqua,
 995      >                    eqquad(adeqqu), codret )
 996             endif
 997 c
 998             eqpntr(5*iaux  ) = jaux
 999             adeqqu = adeqqu + 2*jaux
1000 c
1001           endif
1002 c
1003         endif
1004 c
1005    81 continue
1006 c
1007       endif
1008 c
1009       endif
1010 c
1011 c====
1012 c 9. tableau des types
1013 c====
1014 c
1015 #ifdef _DEBUG_HOMARD_
1016       write (ulsort,90002) '9. tableau des types ; codret', codret
1017 #endif
1018 c
1019       if ( option.eq.1 ) then
1020 c
1021       if ( codret.eq.0 ) then
1022 c
1023       jaux = ibtetr + nbtetr - 1
1024       do 91 , nummai = ibtetr,  jaux
1025         typele(nummai) = typtet
1026    91 continue
1027 c
1028       jaux = ibtria + nbtria - 1
1029       do 92 , nummai = ibtria, jaux
1030         typele(nummai) = typtri
1031    92 continue
1032 c
1033       jaux = ibsegm + nbsegm - 1
1034       do 93 , nummai = ibsegm, jaux
1035         typele(nummai) = typseg
1036    93 continue
1037 c
1038       jaux = ibmapo + nbmapo - 1
1039       do 94 , nummai = ibmapo, jaux
1040         typele(nummai) = typpoi
1041    94 continue
1042 c
1043       jaux = ibquad + nbquad - 1
1044       do 95 , nummai = ibquad, jaux
1045         typele(nummai) = typqua
1046    95 continue
1047 c
1048       jaux = ibhexa + nbhexa - 1
1049       do 96 , nummai = ibhexa, jaux
1050         typele(nummai) = typhex
1051    96 continue
1052 c
1053       jaux = ibpyra + nbpyra - 1
1054       do 97 , nummai = ibpyra, jaux
1055         typele(nummai) = typpyr
1056    97 continue
1057 c
1058       jaux = ibpent + nbpent - 1
1059       do 98 , nummai = ibpent, jaux
1060         typele(nummai) = typpen
1061    98 continue
1062 c
1063       endif
1064 c
1065       endif
1066 c
1067 c====
1068 c 10. la fin
1069 c====
1070 c
1071 #ifdef _DEBUG_HOMARD_
1072       write (ulsort,90002) '10. la fin ; codret', codret
1073 #endif
1074 c
1075       if ( codret.ne.0 ) then
1076 c
1077 #include "envex2.h"
1078 c
1079       write (ulsort,texte(langue,1)) 'Sortie', nompro
1080       write (ulsort,texte(langue,2)) codret
1081 c
1082       endif
1083 c
1084 #ifdef _DEBUG_HOMARD_
1085       write (ulsort,texte(langue,1)) 'Sortie', nompro
1086       call dmflsh (iaux)
1087 #endif
1088 c
1089       end