src/tool/ES_MED/esemm1.F

   1       subroutine esemm1 ( idfmed, nomamd, lnomam,
   2      >                    nbnoto,
   3      >                    coonca, fameno, noeele, famele, typele,
   4      >                    numfam, nomfam,
   5      >                    grfmpo, grfmtb,
   6      >                     nbpqt, inftbl,
   7      >                    eqpntr, eqinfo,
   8      >                    eqnoeu,
   9      >                    eqaret, eqtria, eqquad,
  10      >                    eqtetr, eqhexa,
  11      >                    tabaux, listma,
  12      >                    ulsort, langue, codret )
  13 c ______________________________________________________________________
  14 c
  15 c                             H O M A R D
  16 c
  17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  18 c
  19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  20 c aupres des huissiers de justice Simart et Lavoir a Clamart
  21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  22 c aupres des huissiers de justice
  23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  24 c
  25 c    HOMARD est une marque deposee d'Electricite de France
  26 c
  27 c Copyright EDF 1996
  28 c Copyright EDF 1998
  29 c Copyright EDF 2002
  30 c Copyright EDF 2020
  31 c ______________________________________________________________________
  32 c
  33 c  Entree-Sortie - Ecriture d'un Maillage au format MED - phase 1
  34 c  -      -        -             -                  -           -
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . idfmed . e   .   1    . identificateur du fichier de               .
  40 c .        .     .        . maillage de sortie                         .
  41 c . nomamd . e   . char64 . nom du maillage MED                        .
  42 c . lnomam . e   .   1    . longueur du nom du maillage voulu          .
  43 c . fameno . e   . nbnoto . famille med des noeuds                     .
  44 c . famele . e   . nbelem . famille med des elements                   .
  45 c . noeele . e   . nbelem . noeuds des elements                        .
  46 c .        .     . *nbmane.                                            .
  47 c . typele . e   . nbelem . type des elements                          .
  48 c . coonca .  s  . nbnoto . coordonnees des noeuds dans le calcul      .
  49 c .        .     . *sdimca.                                            .
  50 c . numfam . e   . nbfmed . numero des familles                        .
  51 c . nomfam . e   .10nbfmed. nom des familles                           .
  52 c . grfmpo . e   .0:nbfmed. pointeur des groupes des familles          .
  53 c . grfmtb . e   .10ngrouc. table des groupes des familles             .
  54 c . inftbl . e   .nbpqt*10. tables en caracteres des infos generales   .
  55 c .        .     .        . regroupees par paquets de 80 caracteres    .
  56 c .        .     .        . pour gerer la conversion en pseudo-groupe  .
  57 c .        .     .        . paquet 1 : 1 : 'NomCo'                       .
  58 c .        .     .        .            2/3, 4/5, 6/7 : nom coordonnees .
  59 c .        .     .        .            8 : nom du repere utilise       .
  60 c .        .     .        . paquet 2 : 1 : 'UniteCo'                     .
  61 c .        .     .        .            2/3, 4/5, 6/7 : unite coord.    .
  62 c .        .     .        . paquet 3 : titre (limite a 80 caracteres)  .
  63 c .        .     .        . paquet 4 : 1 : 'NOMAMD'                    .
  64 c .        .     .        .            2-7 :  nom du maillage          .
  65 c . tabaux .     . nbelem . tableau tampon                             .
  66 c .        .     . *nbmane.                                            .
  67 c . listma .     . nbelem . tableau auxiliaire                         .
  68 c . eqpntr . e   .5*nbequi. 5i-4 : nombre de paires de noeuds pour     .
  69 c .        .     .        .        l'equivalence i                     .
  70 c .        .     .        . 5i-3 : idem pour les mailles-points        .
  71 c .        .     .        . 5i-2 : idem pour les aretes                .
  72 c .        .     .        . 5i-1 : idem pour les triangles             .
  73 c .        .     .        . 5i   : idem pour les quadrangles           .
  74 c . eqinfo . e   .33nbequi. nom et description de chaque equivalence   .
  75 c . eqnoeu . e   .2*nbeqno. liste des paires de noeuds equivalents avec.
  76 c .        .     .        . la convention : eqnoeu(i)<-->eqnoeu(i+1)   .
  77 c . eqmapo . e   .2*nbeqmp. idem pour les mailles-points               .
  78 c . eqaret . e   .2*nbeqar. idem pour les aretes                       .
  79 c . eqtria . e   .2*nbeqtr. idem pour les triangles                    .
  80 c . eqquad . e   .2*nbeqqu. idem pour les quadrangles                  .
  81 c . eqtetr . e   .2*nbeqte. idem pour les tetraedres                   .
  82 c . eqhexa . e   .2*nbeqhe. idem pour les hexaedres                    .
  83 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  84 c . langue . e   .    1   . langue des messages                        .
  85 c .        .     .        . 1 : francais, 2 : anglais                  .
  86 c . codret . es  .    1   . code de retour des modules                 .
  87 c .        .     .        . 0 : pas de probleme                        .
  88 c .        .     .        . 1 : probleme                               .
  89 c ______________________________________________________________________
  90 c
  91 c====
  92 c 0. declarations et dimensionnement
  93 c====
  94 c
  95 c 0.1. ==> generalites
  96 c
  97       implicit none
  98       save
  99 c
 100       character*6 nompro
 101       parameter ( nompro = 'ESEMM1' )
 102 c
 103 #include "nblang.h"
 104 #include "consts.h"
 105 c
 106 c 0.2. ==> communs
 107 c
 108 #include "envex1.h"
 109 #include "impr02.h"
 110 #include "indefi.h"
 111 c
 112 #include "envca1.h"
 113 #include "nbutil.h"
 114 c
 115 c 0.3. ==> arguments
 116 c
 117       integer*8 idfmed
 118       integer lnomam
 119       integer ulsort, langue, codret
 120 c
 121       integer nbnoto
 122       integer fameno(nbnoto)
 123       integer noeele(nbelem,nbmane), famele(nbelem), typele(nbelem)
 124       integer grfmpo(0:nbfmed)
 125       integer numfam(nbfmed)
 126       integer eqpntr(5*nbequi)
 127       integer eqnoeu(2*nbeqno)
 128       integer eqaret(2*nbeqar)
 129       integer eqtria(2*nbeqtr), eqquad(2*nbeqqu)
 130       integer eqtetr(2*nbeqte), eqhexa(2*nbeqhe)
 131       integer tabaux(nbelem*nbmane), listma(nbelem)
 132       integer nbpqt
 133 c
 134       character*8 grfmtb(10*ngrouc)
 135       character*8 inftbl(10*nbpqt)
 136       character*8 nomfam(10,nbfmed)
 137       character*8 eqinfo(33*nbequi)
 138 c
 139       character*64 nomamd
 140 c
 141       double precision coonca(nbnoto,sdimca)
 142 c
 143 c 0.4. ==> variables locales
 144 c
 145 #include "meddc0.h"
 146 c
 147       integer typnoe, typpoi, typseg, typtri, typtet, typenc
 148       integer typqua, typhex, typpyr, typpen
 149       integer ibtetr, ibtria, ibsegm, ibmapo, ialist, lamail
 150       integer ibquad, ibhexa, ibpyra, ibpent
 151       integer iaux, jaux, kaux
 152 #ifdef _DEBUG_HOMARD_
 153       integer iaux1
 154 #endif
 155       integer ngro, numero
 156       integer adeqin, adeqno, adeqmp, adeqar, adeqtr, adeqqu
 157       integer adeqte, adeqhe
 158       integer tbiaux(3,10)
 159       integer numdt, numit
 160 c
 161       character*32 saux32
 162       character*64 saux64
 163       character*80 saux80
 164       character*200 sau200
 165 c
 166       double precision instan
 167 c
 168       integer nbmess
 169       parameter ( nbmess = 150 )
 170       character*80 texte(nblang,nbmess)
 171 c ______________________________________________________________________
 172 c
 173 c====
 174 c 1. initialisations
 175 c====
 176 c
 177 #include "impr01.h"
 178 c
 179 #ifdef _DEBUG_HOMARD_
 180       write (ulsort,texte(langue,1)) 'Entree', nompro
 181       call dmflsh (iaux)
 182 #endif
 183 c
 184       texte(1,4) = '(''Maille numero '',i10,'', de type'',i10)'
 185       texte(1,5) =
 186      > '(''==> Ce type de maille est inconnu pour MED.'')'
 187 c
 188       texte(2,4) = '(''Mesh #'',i10,'', with type'',i10)'
 189       texte(2,5) = '(''==> This type is unknown for MED.'')'
 190 c
 191 #include "impr03.h"
 192 #include "esimpr.h"
 193 c
 194       codret = 0
 195 c
 196 #ifdef _DEBUG_HOMARD_
 197       write(ulsort,*) 'nomamd = ', nomamd
 198 #endif
 199 c
 200 c====
 201 c 2. preliminaires
 202 c====
 203 c 2.1. ==> grandeurs de base
 204 c
 205       typnoe = 0
 206       typpoi = edpoi1
 207       if ( degre.eq.1 ) then
 208         typseg = edseg2
 209         typtri = edtri3
 210         typtet = edtet4
 211         typqua = edqua4
 212         typpyr = edpyr5
 213         typhex = edhex8
 214         typpen = edpen6
 215       else
 216         typseg = edseg3
 217         if ( mod(mailet,2).eq.0 ) then
 218           typtri = edtri7
 219         else
 220           typtri = edtri6
 221         endif
 222         typtet = edte10
 223         if ( mod(mailet,3).eq.0 ) then
 224           typqua = edqua9
 225         else
 226           typqua = edqua8
 227         endif
 228         typpyr = edpy13
 229         if ( mod(mailet,5).eq.0 ) then
 230           typhex = edhe27
 231         else
 232           typhex = edhe20
 233         endif
 234         typpen = edpe15
 235       endif
 236 c
 237 c 2.2. ==> rangements des mailles selon le type
 238 c
 239       ibtetr = 0
 240       ibtria = nbtetr
 241       ibsegm = nbtetr + nbtria
 242       ibmapo = nbtetr + nbtria + nbsegm
 243       ibquad = nbtetr + nbtria + nbsegm + nbmapo
 244       ibhexa = nbtetr + nbtria + nbsegm + nbmapo + nbquad
 245       ibpyra = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
 246       ibpent = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
 247      >       + nbpyra
 248 c
 249 cgn      write (ulsort,90002) 'nbtetr', nbtetr
 250 cgn      write (ulsort,90002) 'nbtria', nbtria
 251 cgn      write (ulsort,90002) 'nbsegm', nbsegm
 252 cgn      write (ulsort,90002) 'nbquad', nbquad
 253 cgn      write (ulsort,90002) 'nbhexa', nbhexa
 254 cgn      write (ulsort,90002) 'nbpyra', nbpyra
 255 cgn      write (ulsort,90002) 'typtet,typtri,typseg,typpoi',
 256 cgn     >                      typtet,typtri,typseg,typpoi
 257 cgn      write (ulsort,90002) 'typqua,typhex,typpyr,typpen',
 258 cgn     >                      typqua,typhex,typpyr,typpen
 259       do 22 , lamail = 1, nbelem
 260         typenc = typele(lamail)
 261 cgn      write (ulsort,90002) 'lamail, typenc', lamail, typenc
 262         if ( typenc.eq.typtet ) then
 263           ibtetr = ibtetr+1
 264           ialist = ibtetr
 265         elseif ( typenc.eq.typtri ) then
 266           ibtria = ibtria+1
 267           ialist = ibtria
 268         elseif ( typenc.eq.typseg ) then
 269           ibsegm = ibsegm+1
 270           ialist = ibsegm
 271         elseif ( typenc.eq.typpoi ) then
 272           ibmapo = ibmapo+1
 273           ialist = ibmapo
 274         elseif ( typenc.eq.typqua ) then
 275           ibquad = ibquad+1
 276           ialist = ibquad
 277         elseif ( typenc.eq.typhex ) then
 278           ibhexa = ibhexa+1
 279           ialist = ibhexa
 280         elseif ( typenc.eq.typpyr ) then
 281           ibpyra = ibpyra+1
 282           ialist = ibpyra
 283         elseif ( typenc.eq.typpen ) then
 284           ibpent = ibpent+1
 285           ialist = ibpent
 286         else
 287           write(ulsort,texte(langue,4)) lamail, typenc
 288           write(ulsort,texte(langue,5))
 289           codret = 1
 290         endif
 291         listma(ialist) = lamail
 292    22 continue
 293 c
 294       ibtetr = 1
 295       ibtria = nbtetr + 1
 296       ibsegm = nbtetr + nbtria + 1
 297       ibmapo = nbtetr + nbtria + nbsegm + 1
 298       ibquad = nbtetr + nbtria + nbsegm + nbmapo + 1
 299       ibhexa = nbtetr + nbtria + nbsegm + nbmapo + nbquad + 1
 300       ibpyra = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa + 1
 301       ibpent = nbtetr + nbtria + nbsegm + nbmapo + nbquad + nbhexa
 302      > + nbpyra + 1
 303 cgn      write (ulsort,90002) 'ibtetr, ibtria, ibsegm, ibmapo',
 304 cgn     >                      ibtetr, ibtria, ibsegm, ibmapo
 305 cgn      write (ulsort,90002) 'ibquad, ibhexa, ibpyra, ibpent',
 306 cgn     >                      ibquad, ibhexa, ibpyra, ibpent
 307 c
 308 c 2.3. ==> Instants d'enregistrement du maillage
 309 c
 310       if ( codret.eq.0 ) then
 311 c
 312       numdt = ednodt
 313       numit = ednoit
 314       instan = edundt
 315 c
 316 #ifdef _DEBUG_HOMARD_
 317       write(ulsort,90002) 'numdt', numdt
 318       write(ulsort,90002) 'numit', numit
 319       write(ulsort,90004) 'dt   ', instan
 320 #endif
 321 c
 322       endif
 323 c
 324 c 2.4. ==> description du fichier
 325 c
 326       if ( codret.eq.0 ) then
 327 c
 328       saux80 = blan80
 329 #ifdef _DEBUG_HOMARD_
 330       write (ulsort,texte(langue,3)) 'ESDESC', nompro
 331 #endif
 332       call esdesc ( idfmed, saux80, sau200,
 333      >              ulsort, langue, codret )
 334 c
 335       endif
 336 c
 337 c====
 338 c 3. creation du maillage
 339 c    remarque : on met la meme description que pour le fichier complet
 340 c    attention a ne pas changer les rubriques de cette description car
 341 c    cela sert de reperage pour les codes en couplage avec HOMARD
 342 c    pour definir le numero d'iteration
 343 c====
 344 #ifdef _DEBUG_HOMARD_
 345       write (ulsort,90002) '3. creation du maillage ; codret', codret
 346 #endif
 347 c
 348       if ( codret.eq.0 ) then
 349 c
 350 #ifdef _DEBUG_HOMARD_
 351       write(ulsort,*) 'nomamd = ', nomamd
 352       write(ulsort,90002) 'sdimca', sdimca
 353       write(ulsort,90002) 'mdimca', mdimca
 354 #endif
 355 c
 356 #ifdef _DEBUG_HOMARD_
 357       write (ulsort,texte(langue,3)) 'ESEMM0', nompro
 358 #endif
 359       call esemm0 ( idfmed, nomamd,
 360      >              sdimca, mdimca, sau200,
 361      >               nbpqt, inftbl,
 362      >              ulsort, langue, codret)
 363 c
 364       if ( codret.ne.0 ) then
 365         write(ulsort,texte(langue,78)) 'esemm0', codret
 366       endif
 367 c
 368       endif
 369 c
 370 c====
 371 c 4. les noeuds
 372 c====
 373 #ifdef _DEBUG_HOMARD_
 374       write (ulsort,90002) '4. les noeuds ; codret', codret
 375 #endif
 376 c
 377       if ( codret.eq.0 ) then
 378 c
 379 #ifdef _DEBUG_HOMARD_
 380       write (ulsort,texte(langue,3)) 'ESEMNO', nompro
 381 #endif
 382       call esemno ( idfmed, nomamd,
 383      >              nbnoto, sdimca, coonca, fameno,
 384      >              numdt, numit, instan,
 385      >              ulsort, langue, codret )
 386 c
 387       endif
 388 c
 389 c====
 390 c 5. les mailles :
 391 c    . la connectivite
 392 c    . les numeros des familles
 393 c    On transferera les informations de connectivite depuis le
 394 c    tableau de stockage, noeele, vers le tableau de lecture, itrav1.
 395 c    Pour cela, on explorera les mailles les unes apres les autres.
 396 c    On a donc interet a batir le tableau itrav1 maille par maille.
 397 c    C'est ce que MED appelle le mode entrelace.
 398 c    Remarque : on met une valeur bidon au tableau tbiaux pour ne
 399 c               pas avoir de message avec ftnchek
 400 c====
 401 #ifdef _DEBUG_HOMARD_
 402       write (ulsort,90002) '5. les mailles ; codret', codret
 403 #endif
 404 c
 405       kaux = 1
 406       tbiaux(1,1) = iindef
 407 c
 408 c 5.1. ==> les tetraedres
 409 c
 410       if ( codret.eq.0 ) then
 411 c
 412       if ( nbtetr.gt.0 ) then
 413 c
 414         iaux = 3
 415         if ( degre.eq.1 ) then
 416           jaux = 4
 417         else
 418           jaux = 10
 419         endif
 420 #ifdef _DEBUG_HOMARD_
 421       write (ulsort,texte(langue,3)) 'ESEMMB_te', nompro
 422 #endif
 423         call esemmb ( idfmed, nomamd,
 424      >                iaux, edmail, typtet,
 425      >                nbtetr, jaux, nbelem, kaux,
 426      >                ednoda, nbelem,
 427      >                noeele, tbiaux, famele, listma(ibtetr),
 428      >                numdt, numit, instan,
 429      >                tabaux,
 430      >                ulsort, langue, codret )
 431 c
 432       endif
 433 c
 434       endif
 435 c
 436 c 5.2. ==> les triangles
 437 c
 438       if ( codret.eq.0 ) then
 439 c
 440       if ( nbtria.gt.0 ) then
 441 c
 442         iaux = 2
 443         if ( degre.eq.1 ) then
 444           jaux = 3
 445         elseif ( mod(mailet,2).eq.0 ) then
 446           jaux = 7
 447         else
 448           jaux = 6
 449         endif
 450 #ifdef _DEBUG_HOMARD_
 451       write (ulsort,texte(langue,3)) 'ESEMMB_tr', nompro
 452 #endif
 453         call esemmb ( idfmed, nomamd,
 454      >                iaux, edmail, typtri,
 455      >                nbtria, jaux, nbelem, kaux,
 456      >                ednoda, nbelem,
 457      >                noeele, tbiaux, famele, listma(ibtria),
 458      >                numdt, numit, instan,
 459      >                tabaux,
 460      >                ulsort, langue, codret )
 461 c
 462       endif
 463 c
 464       endif
 465 c
 466 c 5.3. ==> les segments
 467 c
 468       if ( codret.eq.0 ) then
 469 c
 470       if ( nbsegm.gt.0 ) then
 471 c
 472         iaux = 1
 473         if ( degre.eq.1 ) then
 474           jaux = 2
 475         else
 476           jaux = 3
 477         endif
 478 #ifdef _DEBUG_HOMARD_
 479       write (ulsort,texte(langue,3)) 'ESEMMB_se', nompro
 480 #endif
 481         call esemmb ( idfmed, nomamd,
 482      >                iaux, edmail, typseg,
 483      >                nbsegm, jaux, nbelem, kaux,
 484      >                ednoda, nbelem,
 485      >                noeele, tbiaux, famele, listma(ibsegm),
 486      >                numdt, numit, instan,
 487      >                tabaux,
 488      >                ulsort, langue, codret )
 489 c
 490       endif
 491 c
 492       endif
 493 c
 494 c 5.4. ==> les mailles-points
 495 c
 496       if ( codret.eq.0 ) then
 497 c
 498       if ( nbmapo.gt.0 ) then
 499 c
 500         iaux = 0
 501         jaux = 1
 502 #ifdef _DEBUG_HOMARD_
 503       write (ulsort,texte(langue,3)) 'ESEMMB_mp', nompro
 504 #endif
 505         call esemmb ( idfmed, nomamd,
 506      >                iaux, edmail, typpoi,
 507      >                nbmapo, jaux, nbelem, kaux,
 508      >                ednoda, nbelem,
 509      >                noeele, tbiaux, famele, listma(ibmapo),
 510      >                numdt, numit, instan,
 511      >                tabaux,
 512      >                ulsort, langue, codret )
 513 c
 514       endif
 515 c
 516       endif
 517 c
 518 c 5.5. ==> les quadrangles
 519 c
 520       if ( codret.eq.0 ) then
 521 c
 522       if ( nbquad.gt.0 ) then
 523 c
 524         iaux = 4
 525         if ( degre.eq.1 ) then
 526           jaux = 4
 527         elseif ( mod(mailet,3).eq.0 ) then
 528           jaux = 9
 529         else
 530           jaux = 8
 531         endif
 532 #ifdef _DEBUG_HOMARD_
 533       write (ulsort,texte(langue,3)) 'ESEMMB_qu', nompro
 534 #endif
 535         call esemmb ( idfmed, nomamd,
 536      >                iaux, edmail, typqua,
 537      >                nbquad, jaux, nbelem, kaux,
 538      >                ednoda, nbelem,
 539      >                noeele, tbiaux, famele, listma(ibquad),
 540      >                numdt, numit, instan,
 541      >                tabaux,
 542      >                ulsort, langue, codret )
 543 c
 544       endif
 545 c
 546       endif
 547 c
 548 c 5.6. ==> les pyramides
 549 c
 550       if ( codret.eq.0 ) then
 551 c
 552       if ( nbpyra.gt.0 ) then
 553 c
 554         iaux = 5
 555         if ( degre.eq.1 ) then
 556           jaux = 5
 557         else
 558           jaux = 13
 559         endif
 560 #ifdef _DEBUG_HOMARD_
 561       write (ulsort,texte(langue,3)) 'ESEMMB_py', nompro
 562 #endif
 563         call esemmb ( idfmed, nomamd,
 564      >                iaux, edmail, typpyr,
 565      >                nbpyra, jaux, nbelem, kaux,
 566      >                ednoda, nbelem,
 567      >                noeele, tbiaux, famele, listma(ibpyra),
 568      >                numdt, numit, instan,
 569      >                tabaux,
 570      >                ulsort, langue, codret )
 571 c
 572       endif
 573 c
 574       endif
 575 c
 576 c 5.7. ==> les hexaedres
 577 c
 578       if ( codret.eq.0 ) then
 579 c
 580       if ( nbhexa.gt.0 ) then
 581 c
 582         iaux = 6
 583         if ( degre.eq.1 ) then
 584           jaux = 8
 585         elseif ( mod(mailet,5).eq.0 ) then
 586           jaux = 27
 587         else
 588           jaux = 20
 589         endif
 590 #ifdef _DEBUG_HOMARD_
 591       write (ulsort,texte(langue,3)) 'ESEMMB_he', nompro
 592 #endif
 593         call esemmb ( idfmed, nomamd,
 594      >                iaux, edmail, typhex,
 595      >                nbhexa, jaux, nbelem, kaux,
 596      >                ednoda, nbelem,
 597      >                noeele, tbiaux, famele, listma(ibhexa),
 598      >                numdt, numit, instan,
 599      >                tabaux,
 600      >                ulsort, langue, codret )
 601 c
 602       endif
 603 c
 604       endif
 605 c
 606 c 5.8. ==> les pentaedres
 607 c
 608       if ( codret.eq.0 ) then
 609 c
 610       if ( nbpent.gt.0 ) then
 611 c
 612         iaux = 7
 613         if ( degre.eq.1 ) then
 614           jaux = 6
 615         else
 616           jaux = 15
 617         endif
 618 #ifdef _DEBUG_HOMARD_
 619       write (ulsort,texte(langue,3)) 'ESEMMB_pe', nompro
 620 #endif
 621         call esemmb ( idfmed, nomamd,
 622      >                iaux, edmail, typpen,
 623      >                nbpent, jaux, nbelem, kaux,
 624      >                ednoda, nbelem,
 625      >                noeele, tbiaux, famele, listma(ibpent),
 626      >                numdt, numit, instan,
 627      >                tabaux,
 628      >                ulsort, langue, codret )
 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. les familles ; codret', codret
 639 #endif
 640 c
 641       if ( codret .eq. 0) then
 642 c
 643       if ( nbfmed.ne.0 ) then
 644 c
 645 #ifdef _DEBUG_HOMARD_
 646       write (ulsort,90002) 'Nombre de familles MED', nbfmed
 647 #endif
 648 c
 649       do 61 , iaux = 1 , nbfmed
 650 c
 651         if ( codret.eq.0 ) then
 652 c
 653         numero = numfam(iaux)
 654 c
 655         if ( ngrouc.eq.0 ) then
 656           ngro = 0
 657         else
 658           ngro = ( grfmpo(iaux) - grfmpo(iaux-1) ) / 10
 659         endif
 660 c
 661         saux64( 1: 8) = nomfam(1,iaux)
 662         saux64( 9:16) = nomfam(2,iaux)
 663         saux64(17:24) = nomfam(3,iaux)
 664         saux64(25:32) = nomfam(4,iaux)
 665         saux64(33:40) = nomfam(5,iaux)
 666         saux64(41:48) = nomfam(6,iaux)
 667         saux64(49:56) = nomfam(7,iaux)
 668         saux64(57:64) = nomfam(8,iaux)
 669 c
 670         endif
 671 c
 672 #ifdef _DEBUG_HOMARD_
 673 c
 674         if ( codret.eq.0 ) then
 675 c        write (ulsort,90002) 'Familles MED numero ', iaux
 676 c
 677         kaux = 0
 678         do 621 , jaux = 1 , nbnoto
 679 cgn      print *,'. fameno(jaux) = ',fameno(jaux)
 680           if ( fameno(jaux).eq.numero ) then
 681             kaux = kaux + 1
 682           endif
 683   621   continue
 684 c
 685         iaux1 = 0
 686         do 622 , jaux = 1 , nbelem
 687 cgn      print *,'. famele(jaux)) = ',famele(jaux)
 688           if ( famele(jaux).eq.numero ) then
 689             iaux1 = iaux1 + 1
 690           endif
 691   622   continue
 692 c
 693         call utinfm ( numero, saux64,
 694      >                ngro, grfmtb(grfmpo(iaux-1)+1),
 695      >                kaux, iaux1,
 696      >                ulsort, langue, codret )
 697 c
 698         endif
 699 #endif
 700 c
 701         if ( codret.eq.0 ) then
 702 c
 703 #ifdef _DEBUG_HOMARD_
 704       write (ulsort,texte(langue,3)) 'MFACRE', nompro
 705 #endif
 706         call mfacre ( idfmed, nomamd, saux64, numero,
 707      >                ngro, grfmtb(grfmpo(iaux-1)+1), codret )
 708 c
 709         if ( codret.ne.0 ) then
 710           write(ulsort,texte(langue,78)) 'mfacre', codret
 711         endif
 712 c
 713         endif
 714 c
 715    61 continue
 716 c
 717       endif
 718 c
 719       endif
 720 c
 721 c====
 722 c 7. equivalences
 723 c    la convention de stockage MED des listes d'equivalences est que
 724 c    l'entite Liste(j) est associee a Liste(j+1)
 725 c====
 726 #ifdef _DEBUG_HOMARD_
 727       write (ulsort,90002) '7. equivalences ; codret', codret
 728 #endif
 729 c
 730       if ( codret.eq.0 ) then
 731 c
 732       adeqin = 1
 733       adeqno = 1
 734       adeqmp = 1
 735       adeqar = 1
 736       adeqtr = 1
 737       adeqqu = 1
 738       adeqte = 1
 739       adeqhe = 1
 740 c
 741       do 71 , iaux = 1, nbequi
 742 c
 743 c 7.1. ==> nom et description de l'equivalence
 744 c
 745         if ( codret.eq.0 ) then
 746 c
 747         call uts8ch ( eqinfo(adeqin), 64, saux64,
 748      >                ulsort, langue, codret )
 749         adeqin = adeqin + 8
 750 c
 751         endif
 752 c
 753         if ( codret.eq.0 ) then
 754 c
 755         call uts8ch ( eqinfo(adeqin), 200, sau200,
 756      >                ulsort, langue, codret )
 757         adeqin = adeqin + 25
 758 c
 759         endif
 760 c
 761 c 7.2. ==> creation de l'equivalence dans le fichier
 762 c
 763         if ( codret.eq.0 ) then
 764 c
 765 #ifdef _DEBUG_HOMARD_
 766       write (ulsort,texte(langue,3)) 'MEQCRE', nompro
 767 #endif
 768         call meqcre ( idfmed, nomamd, saux64, sau200, codret )
 769         if ( codret.ne.0 ) then
 770           write(ulsort,texte(langue,78)) 'meqcre', codret
 771         endif
 772 c
 773         endif
 774 c
 775 c 7.3. ==> equivalence de noeuds
 776 c
 777         if ( codret.eq.0 ) then
 778 c
 779         jaux = eqpntr(5*iaux-4)
 780         if ( jaux.gt.0 ) then
 781 c
 782 #ifdef _DEBUG_HOMARD_
 783       write (ulsort,texte(langue,3)) 'ESEMMQ_no', nompro
 784 #endif
 785           call esemmq ( idfmed, nomamd, saux64,
 786      >                   numdt,  numit,
 787      >                  ednoeu, typnoe,
 788      >                    jaux, eqnoeu(adeqno),
 789      >                  ulsort, langue, codret )
 790           if ( codret.ne.0 ) then
 791             write(ulsort,texte(langue,78)) 'ESEMMQ_no', codret
 792           endif
 793           adeqno = adeqno + 2*jaux
 794 c
 795         endif
 796 c
 797         endif
 798 c
 799 c 7.4. ==> equivalence de mailles-points
 800 c
 801         if ( codret.eq.0 ) then
 802 c
 803         jaux = eqpntr(5*iaux-3)
 804         if ( jaux.gt.0 ) then
 805 c
 806           codret = 74
 807 c
 808         endif
 809 c
 810         endif
 811 c
 812 c 7.5. ==> equivalence de segments
 813 c
 814         if ( codret.eq.0 ) then
 815 c
 816         jaux = eqpntr(5*iaux-2)
 817         if ( jaux.gt.0 ) then
 818 c
 819 #ifdef _DEBUG_HOMARD_
 820       write (ulsort,texte(langue,3)) 'ESEMMQ_ar', nompro
 821 #endif
 822           call esemmq ( idfmed, nomamd, saux64,
 823      >                   numdt,  numit,
 824      >                  edmail, typseg,
 825      >                    jaux, eqaret(adeqar),
 826      >                  ulsort, langue, codret )
 827           if ( codret.ne.0 ) then
 828             write(ulsort,texte(langue,78)) 'ESEMMQ_ar', codret
 829           endif
 830           adeqar = adeqar + 2*jaux
 831 c
 832         endif
 833 c
 834         endif
 835 c
 836 c 7.6. ==> equivalence de triangles
 837 c
 838         if ( codret.eq.0 ) then
 839 c
 840         jaux = eqpntr(5*iaux-1)
 841         if ( jaux.gt.0 ) then
 842 c
 843 #ifdef _DEBUG_HOMARD_
 844       write (ulsort,texte(langue,3)) 'ESEMMQ_tr', nompro
 845 #endif
 846           call esemmq ( idfmed, nomamd, saux64,
 847      >                   numdt,  numit,
 848      >                  edmail, typtri,
 849      >                    jaux, eqtria(adeqtr),
 850      >                  ulsort, langue, codret )
 851           if ( codret.ne.0 ) then
 852             write(ulsort,texte(langue,78)) 'ESEMMQ_tr', codret
 853           endif
 854           adeqtr = adeqtr + 2*jaux
 855 c
 856         endif
 857 c
 858         endif
 859 c
 860 c 7.7. ==> equivalence de quadrangles
 861 c
 862         if ( codret.eq.0 ) then
 863 c
 864         jaux = eqpntr(5*iaux)
 865         if ( jaux.gt.0 ) then
 866 c
 867 #ifdef _DEBUG_HOMARD_
 868       write (ulsort,texte(langue,3)) 'ESEMMQ_qu', nompro
 869 #endif
 870           call esemmq ( idfmed, nomamd, saux64,
 871      >                   numdt,  numit,
 872      >                  edmail, typqua,
 873      >                    jaux, eqquad(adeqqu),
 874      >                  ulsort, langue, codret )
 875           if ( codret.ne.0 ) then
 876             write(ulsort,texte(langue,78)) 'ESEMMQ_qu', codret
 877           endif
 878           adeqqu = adeqqu + 2*jaux
 879 c
 880         endif
 881 c
 882         endif
 883 c
 884 c 7.9. ==> equivalence d'hexaedres
 885 c
 886         if ( codret.eq.0 ) then
 887 c
 888         if ( nbeqhe.gt.0 ) then
 889 c
 890 cgn#ifdef _DEBUG_HOMARD_
 891 cgn      write (ulsort,texte(langue,3)) 'ESEMMQ_he', nompro
 892 cgn#endif
 893 cgn          call esemmq ( idfmed, nomamd, saux64,
 894 cgn     >                   numdt,  numit,
 895 cgn     >                  edmail, typhex,
 896 cgn     >                  nbeqhe, eqhexa(adeqhe),
 897 cgn     >                  ulsort, langue, codret )
 898 cgn          if ( codret.ne.0 ) then
 899 cgn            write(ulsort,texte(langue,78)) 'ESEMMQ_he', codret
 900 cgn          endif
 901 cgn          adeqhe = adeqhe + 2*nbeqhe
 902 c
 903         endif
 904 c
 905         endif
 906 c
 907    71 continue
 908 c
 909       endif
 910 c
 911 c====
 912 c 8. informations
 913 c====
 914 #ifdef _DEBUG_HOMARD_
 915       write (ulsort,90002) '8. informations ; codret', codret
 916 #endif
 917 c
 918       if ( codret.eq.0 ) then
 919 c
 920       write(ulsort,texte(langue,22)) nomamd(1:lnomam)
 921 c
 922       tbiaux(1,1) = nbmapo
 923       tbiaux(1,2) = nbsegm
 924       tbiaux(1,3) = nbtria
 925       tbiaux(1,4) = nbquad
 926       tbiaux(1,5) = nbtetr
 927       tbiaux(1,6) = nbhexa
 928       tbiaux(1,7) = nbpent
 929       tbiaux(1,8) = nbpyra
 930       tbiaux(2,1) = 2
 931       if ( degre.eq.1 ) then
 932         tbiaux(2,2) = 4
 933       else
 934         tbiaux(2,2) = 5
 935       endif
 936       do 81 , iaux = 3 , 8
 937         tbiaux(2,iaux) = tbiaux(2,iaux-1) + 3
 938    81 continue
 939 c
 940       iaux = 1
 941       jaux = 0
 942       if ( langue.eq.1 ) then
 943 c                 12345678901234567890123456789012
 944         saux32 = 'dans le fichier                 '
 945       else
 946         saux32 = 'in the file                     '
 947       endif
 948 #ifdef _DEBUG_HOMARD_
 949       write (ulsort,texte(langue,3)) 'UTINMA', nompro
 950 #endif
 951       call utinma ( iaux, saux32,
 952      >              sdimca, mdimca, degre,
 953      >              nbnoto, jaux, jaux, jaux,
 954      >              jaux, jaux,
 955      >              iaux, nbelem,
 956      >              nbmapo, tbiaux(1,2), tbiaux(1,3), tbiaux(1,4),
 957      >              tbiaux(1,5), tbiaux(1,6), tbiaux(1,8), tbiaux(1,7),
 958      >              jaux,
 959      >              nbmane, nbmaae, nbmafe,
 960      >              ulsort, langue, codret)
 961 c
 962       write(ulsort,texte(langue,29)) nbfmed
 963       write(ulsort,texte(langue,31)) ngrouc
 964 c
 965       if ( nbequi.ne.0 ) then
 966         write(ulsort,texte(langue,41)) nbequi
 967         write(ulsort,texte(langue,42)) mess14(langue,3,-1), nbeqno
 968         tbiaux(2,1) = 0
 969         tbiaux(2,2) = 1
 970         tbiaux(2,3) = 2
 971         tbiaux(2,4) = 4
 972         tbiaux(3,1) = nbeqmp
 973         tbiaux(3,2) = nbeqar
 974         tbiaux(3,3) = nbeqtr
 975         tbiaux(3,4) = nbeqqu
 976         do 821 , iaux = 1 , 4
 977           if ( tbiaux(1,iaux).gt.0 ) then
 978             write(ulsort,texte(langue,42))
 979      >            mess14(langue,3,tbiaux(2,iaux)), tbiaux(3,iaux)
 980           endif
 981   821   continue
 982         tbiaux(2,5) = 3
 983         tbiaux(2,6) = 6
 984         tbiaux(3,5) = nbeqte
 985         tbiaux(3,6) = nbeqhe
 986 cgn        do 822 , iaux = 5, 6
 987 cgn          if ( ( tbiaux(1,iaux).gt.0 ) .and.
 988 cgn     >         ( tbiaux(3,iaux).gt.0 ) ) then
 989 cgn            write(ulsort,texte(langue,42))
 990 cgn     >            mess14(langue,3,tbiaux(2,iaux)), tbiaux(3,iaux)
 991 cgn          endif
 992 cgn  822   continue
 993       endif
 994 c
 995       endif
 996 c
 997 c====
 998 c 9. la fin
 999 c====
1000 c
1001       if ( codret.ne.0 ) then
1002 c
1003 #include "envex2.h"
1004 c
1005       write (ulsort,texte(langue,1)) 'Sortie', nompro
1006       write (ulsort,texte(langue,2)) codret
1007 c
1008       endif
1009 c
1010 #ifdef _DEBUG_HOMARD_
1011       write (ulsort,texte(langue,1)) 'Sortie', nompro
1012       call dmflsh (iaux)
1013 #endif
1014 c
1015       end