src/tool/ES_MED/eslmm1.F

   1       subroutine eslmm1 ( idfmed, nomamd, lnomam,
   2      >                    titre,
   3      >                    sdimca, mdimca,
   4      >                     degre, mailet, homolo, nbmane,
   5      >                    nbelem, nbmaae, nbmafe,
   6      >                    nbmapo, nbsegm, nbtria, nbtetr,
   7      >                    nbquad, nbhexa, nbpent, nbpyra,
   8      >                    nbfmed, ngrouc, nbgrm,
   9      >                    nbequi, nbeqno, nbeqmp, nbeqar,
  10      >                    nbeqtr, nbeqqu,
  11      >                    nbnoto,
  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 - Lecture du Maillage au format MED - phase 1
  34 c  -      -        -          -                  -           -
  35 c  Remarque : on suppose que le maillage est conforme
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . idfmed . e   .   1    . identificateur du fichier de               .
  41 c .        .     .        . maillage d'entree                          .
  42 c . nomamd . e   . char64 . nom du maillage MED                        .
  43 c . lnomam . e   .   1    . longueur du nom du maillage voulu          .
  44 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  45 c . langue . e   .    1   . langue des messages                        .
  46 c .        .     .        . 1 : francais, 2 : anglais                  .
  47 c . codret . es  .    1   . code de retour des modules                 .
  48 c .        .     .        . 0 : pas de probleme                        .
  49 c .        .     .        . 1 : probleme                               .
  50 c ______________________________________________________________________
  51 c
  52 c====
  53 c 0. declarations et dimensionnement
  54 c====
  55 c
  56 c 0.1. ==> generalites
  57 c
  58       implicit none
  59       save
  60 c
  61       character*6 nompro
  62       parameter ( nompro = 'ESLMM1' )
  63 c
  64 #include "nblang.h"
  65 #include "consts.h"
  66 c
  67 #include "equiva.h"
  68 c
  69 c 0.2. ==> communs
  70 c
  71 #include "envex1.h"
  72 #include "impr02.h"
  73 c
  74 c 0.3. ==> arguments
  75 c
  76       integer*8 idfmed
  77       integer lnomam
  78       integer sdimca, mdimca
  79       integer degre, mailet, homolo, nbmane
  80       integer nbelem, nbmaae, nbmafe,
  81      >        nbmapo, nbsegm, nbtria, nbtetr,
  82      >        nbquad, nbhexa, nbpent, nbpyra,
  83      >        nbfmed, ngrouc, nbgrm,
  84      >        nbequi, nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu
  85       integer nbnoto
  86 c
  87       character*64 nomamd
  88       character*(*) titre
  89 c
  90       integer ulsort, langue, codret
  91 c
  92 c 0.4. ==> variables locales
  93 c
  94 #include "meddc0.h"
  95 c
  96       integer nbmai1, nbmai2
  97       integer nbseg2, nbseg3
  98       integer nbtri3, nbtri6, nbtri7
  99       integer nbtet4, nbte10
 100       integer nbqua4, nbqua8, nbqua9
 101       integer nbhex8, nbhe20, nbhe27
 102       integer nbpen6, nbpe15
 103       integer nbpyr5, nbpy13
 104       integer codre1, codre2, codre3, codre4, codre5
 105       integer codre0
 106       integer ngro
 107       integer typnoe, typpoi, typseg, typtri, typqua
 108 c
 109       integer iaux, jaux
 110       integer iaux1, iaux2, iaux3, iaux4, iaux5
 111       integer tbiaux(3,10)
 112       integer numdt, numit
 113       integer nstep, nctcor
 114 c
 115       character*32 saux32
 116       character*64 saux64
 117       character*200 sau200
 118 c
 119       integer nbmess
 120       parameter ( nbmess = 150 )
 121       character*80 texte(nblang,nbmess)
 122 c ______________________________________________________________________
 123 c
 124 c====
 125 c 1. initialisations
 126 c====
 127 c
 128 c 1.1. ==> les messages
 129 c
 130 #include "impr01.h"
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133       write (ulsort,texte(langue,1)) 'Entree', nompro
 134       call dmflsh (iaux)
 135 #endif
 136 c
 137       texte(1,4) = '(''Nombre de mailles '',a6,'' :'',i10)'
 138       texte(1,5) =
 139      > '(''Ces types de mailles ne sont pas acceptees par HOMARD.'')'
 140 c
 141       texte(2,4) = '(''Number of meshes '',a6,'' :'',i10)'
 142       texte(2,5) =
 143      > '(''These kinds of elements are not treated in HOMARD.'')'
 144 c
 145 #include "esimpr.h"
 146 c
 147       nbnoto = 0
 148       nbmane = 0
 149       nbmaae = 0
 150       nbmafe = 0
 151       degre  = 0
 152       homolo = 0
 153 c
 154       nbfmed = 0
 155       ngrouc = 0
 156       nbgrm = 0
 157 c
 158       typnoe = 0
 159 c
 160       numdt = ednodt
 161       numit = ednoit
 162 c
 163       titre(1:64) = nomamd
 164       iaux = len(titre)
 165       do 11, jaux = 65 , iaux
 166         titre(jaux:jaux) = ' '
 167    11 continue
 168 c
 169 c====
 170 c 2. recherche des differents nombres
 171 c====
 172 c 2.1. ==> nombre de sommets
 173 c
 174       if ( codret.eq.0 ) then
 175 c
 176 #ifdef _DEBUG_HOMARD_
 177       write (ulsort,texte(langue,3)) 'ESLMMN', nompro
 178 #endif
 179       call eslmmn ( idfmed, nomamd, lnomam,
 180      >              nbnoto,
 181      >              ulsort, langue, codret )
 182 c
 183       endif
 184 c
 185 c 2.2. ==> les mailles
 186 c
 187       if ( codret.eq.0 ) then
 188 c
 189 #ifdef _DEBUG_HOMARD_
 190       write (ulsort,texte(langue,3)) 'ESLNMA', nompro
 191 #endif
 192       call eslnma ( idfmed, nomamd, mdimca,
 193      >              nbelem, nbmapo, nbsegm, nbtria, nbtetr,
 194      >              nbquad, nbhexa, nbpyra, nbpent,
 195      >              nbseg2, nbseg3,
 196      >              nbtri3, nbtri6, nbtri7,
 197      >              nbtet4, nbte10,
 198      >              nbqua4, nbqua8, nbqua9,
 199      >              nbhex8, nbhe20, nbhe27,
 200      >              nbpen6, nbpe15,
 201      >              nbpyr5, nbpy13,
 202      >              ulsort, langue, codret )
 203 c
 204       endif
 205 c
 206       if ( codret.eq.0 ) then
 207 c
 208       if ( nbhe27.gt.0 ) then
 209 c
 210         write (ulsort,texte(langue,4)) 'HEXA27', nbhe27
 211         write (ulsort,texte(langue,5))
 212         codret = 3
 213 c
 214       endif
 215       mailet = 1
 216       if ( nbtri7.gt.0 ) then
 217         mailet = mailet*2
 218       endif
 219       if ( nbqua9.gt.0 ) then
 220         mailet = mailet*3
 221       endif
 222       if ( nbhe27.gt.0 ) then
 223         mailet = mailet*5
 224       endif
 225 c
 226       endif
 227 c
 228 c 2.3. ==> nombre de familles et de groupes cumules
 229 c
 230       if ( codret.eq.0 ) then
 231 c
 232 #ifdef _DEBUG_HOMARD_
 233       write (ulsort,texte(langue,3)) 'MFANFA', nompro
 234 #endif
 235       call mfanfa ( idfmed, nomamd, nbfmed, codret )
 236 c
 237       endif
 238 c
 239       if ( codret.eq.0 ) then
 240 c
 241       do 23 , iaux = 1 , nbfmed
 242 c
 243         if ( codret.eq.0 ) then
 244 c
 245 #ifdef _DEBUG_HOMARD_
 246         write (ulsort,texte(langue,3)) 'MFANFG', nompro
 247 #endif
 248         call mfanfg ( idfmed, nomamd, iaux, ngro, codre0 )
 249         codret = max ( abs(codre0), codret )
 250 c
 251         ngrouc = ngrouc + ngro
 252         nbgrm = max ( ngro, nbgrm )
 253 c
 254         endif
 255 c
 256    23 continue
 257 c
 258       endif
 259 c
 260 c====
 261 c 3. nombres deduits
 262 c====
 263 c
 264       if ( codret.eq.0 ) then
 265 c
 266 c 3.1. ==> Nombre de mailles
 267 c
 268       nbmai1 = nbtet4 + nbtri3 + nbseg2
 269      >       + nbqua4 + nbhex8 + nbpyr5 + nbpen6
 270       nbmai2 = nbte10 + nbtri6 + nbseg3
 271      >       + nbqua8 + nbhe20 + nbpy13 + nbpe15
 272      >       + nbtri7 + nbqua9 + nbhe27
 273 c
 274 c 3.2. ==> nbmane : nombre maximal de noeud par element
 275 c
 276       if ( nbmai1.gt.0 ) then
 277 c
 278         if ( nbmai2.gt.0 ) then
 279           write(ulsort,texte(langue,27)) nbmai1, nbmai2
 280           codret = 30
 281         endif
 282 c
 283         degre  = 1
 284 c
 285         if ( nbhexa.gt.0 ) then
 286           nbmane = 8
 287         elseif ( nbpent.gt.0 ) then
 288           nbmane = 6
 289         elseif ( nbpyra.gt.0 ) then
 290           nbmane = 5
 291         elseif ( nbtetr.gt.0 .or. nbquad.gt.0 ) then
 292           nbmane = 4
 293         elseif ( nbtria.gt.0 ) then
 294           nbmane = 3
 295         else
 296           nbmane = 2
 297         endif
 298 c
 299       else if ( nbmai2.gt.0 ) then
 300 c
 301         degre  = 2
 302 c
 303         if ( nbhe27.gt.0 ) then
 304           nbmane = 27
 305         elseif ( nbhe20.gt.0 ) then
 306           nbmane = 20
 307         elseif ( nbpent.gt.0 ) then
 308           nbmane = 15
 309         elseif ( nbpyra.gt.0 ) then
 310           nbmane = 13
 311         elseif ( nbtetr.gt.0 ) then
 312           nbmane = 10
 313         elseif ( nbqua9.gt.0 ) then
 314           nbmane = 9
 315         elseif ( nbqua8.gt.0 ) then
 316           nbmane = 8
 317         elseif ( nbtri7.gt.0 ) then
 318           nbmane = 7
 319         elseif ( nbtri6.gt.0 ) then
 320           nbmane = 6
 321         else
 322           nbmane = 3
 323         endif
 324 c
 325       else
 326 c
 327         nbmane = 1
 328 c
 329       endif
 330 c
 331 c 3.3. ==> nbmaae : nombre maximal d'aretes par element
 332 c          nbmafe : nombre maximal de faces par element
 333 c
 334       if ( nbhexa.gt.0 ) then
 335         nbmaae = 12
 336         nbmafe = 6
 337       else if ( nbpent.gt.0 ) then
 338         nbmaae = 9
 339         nbmafe = 5
 340       else if ( nbpyra.gt.0 ) then
 341         nbmaae = 8
 342         nbmafe = 5
 343       else if ( nbtetr.gt.0 ) then
 344         nbmaae = 6
 345         nbmafe = 4
 346       else if ( nbquad.gt.0 ) then
 347         nbmaae = 4
 348         nbmafe = 1
 349       else if ( nbtria.gt.0 ) then
 350         nbmaae = 3
 351         nbmafe = 1
 352       else if ( nbsegm.gt.0 ) then
 353         nbmaae = 1
 354       endif
 355 c
 356       endif
 357 c
 358 c====
 359 c 4. les equivalences
 360 c    remarque : il faut le faire seulement maintenant, sinon on ne
 361 c               sait pas ce que valent typseg, typtri et typqua.
 362 c====
 363 c
 364 c 4.1. ==> le nombre d'equivalences
 365 c
 366       if ( codret.eq.0 ) then
 367 c
 368 #ifdef _DEBUG_HOMARD_
 369         write (ulsort,texte(langue,3)) 'MEQNEQ', nompro
 370 #endif
 371       call meqneq ( idfmed, nomamd, nbequi, codret )
 372 c
 373       endif
 374 c
 375 c 4.2. ==> combien de paires d'entites impliquees
 376 c
 377       nbeqno = 0
 378       nbeqmp = 0
 379       nbeqar = 0
 380       nbeqtr = 0
 381       nbeqqu = 0
 382 c
 383       typpoi = edpoi1
 384       if ( degre.eq.1 ) then
 385         typseg = edseg2
 386         typtri = edtri3
 387         typqua = edqua4
 388       else
 389         typseg = edseg3
 390         typtri = edtri6
 391         typqua = edqua8
 392       endif
 393 c
 394       if ( codret.eq.0 ) then
 395 c
 396       jaux = 0
 397 c
 398       do 42 , iaux = 1, nbequi
 399 c
 400 c 4.2.1. ==> nom et description de l'equivalence
 401 c
 402         if ( codret.eq.0 ) then
 403 c
 404 #ifdef _DEBUG_HOMARD_
 405         write (ulsort,texte(langue,3)) 'MEQEQI', nompro
 406 #endif
 407         call meqeqi ( idfmed, nomamd, iaux,
 408      >                saux64, sau200, nstep, nctcor, codret )
 409 c
 410         endif
 411 c
 412 c 4.2.2. ==> si l'equivalence est interdite, on passe a la suivante
 413 c
 414         if ( codret.eq.0 ) then
 415 c
 416         if ( saux64.eq.eqinte ) then
 417 c
 418           jaux = jaux + 1
 419           goto 42
 420 c
 421         endif
 422 c
 423         endif
 424 c
 425 c 4.2.3. ==> nombre d'entites dans chaque categorie
 426 c
 427         if ( codret.eq.0 ) then
 428 c
 429 #ifdef _DEBUG_HOMARD_
 430         write (ulsort,texte(langue,3)) 'MEQCSZ', nompro
 431 #endif
 432         call meqcsz ( idfmed, nomamd, saux64, numdt, numit,
 433      >                ednoeu, typnoe,
 434      >                iaux1, codre1 )
 435 c
 436         if ( nbmapo.ne.0 ) then
 437           call meqcsz ( idfmed, nomamd, saux64, numdt, numit,
 438      >                  edmail, typpoi,
 439      >                  iaux2, codre2 )
 440         else
 441           iaux2 = 0
 442           codre2 = 0
 443         endif
 444 c
 445         if ( nbsegm.ne.0 ) then
 446           call meqcsz ( idfmed, nomamd, saux64, numdt, numit,
 447      >                  edmail, typseg,
 448      >                  iaux3, codre3 )
 449         else
 450           iaux3 = 0
 451           codre3 = 0
 452         endif
 453 c
 454         if ( nbtria.ne.0 ) then
 455           call meqcsz ( idfmed, nomamd, saux64, numdt, numit,
 456      >                  edmail, typtri,
 457      >                  iaux4, codre4 )
 458         else
 459           iaux4 = 0
 460           codre4 = 0
 461         endif
 462 c
 463         if ( nbquad.ne.0 ) then
 464           call meqcsz ( idfmed, nomamd, saux64, numdt, numit,
 465      >                  edmail, typqua,
 466      >                  iaux5, codre5 )
 467         else
 468           iaux5 = 0
 469           codre5 = 0
 470         endif
 471 c
 472         codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 473         codret = max ( abs(codre0), codret,
 474      >                 codre1, codre2, codre3, codre4, codre5 )
 475 c
 476         endif
 477 c
 478         if ( codret.eq.0 ) then
 479 c
 480         nbeqno = nbeqno + iaux1
 481         nbeqmp = nbeqmp + iaux2
 482         nbeqar = nbeqar + iaux3
 483         nbeqtr = nbeqtr + iaux4
 484         nbeqqu = nbeqqu + iaux5
 485 c
 486         endif
 487 c
 488    42 continue
 489 c
 490       endif
 491 c
 492 c 4.3. ==> bilan
 493 c
 494       if ( codret.eq.0 ) then
 495 c
 496       nbequi = nbequi - jaux
 497 c
 498       if ( nbeqtr.ne.0 .or. nbeqqu.ne.0 ) then
 499         homolo = 3
 500       elseif ( nbeqar.ne.0 ) then
 501         homolo = 2
 502       elseif ( nbeqno.ne.0 ) then
 503         homolo = 1
 504       else
 505         homolo = 0
 506       endif
 507 c
 508       endif
 509 c
 510 c====
 511 c 5. Informations
 512 c====
 513 c
 514       if ( codret.eq.0 ) then
 515 c
 516       write(ulsort,texte(langue,22)) nomamd(1:lnomam)
 517 c
 518       tbiaux(1,1) = nbmapo
 519       tbiaux(1,2) = nbsegm
 520       tbiaux(1,3) = nbtria
 521       tbiaux(1,4) = nbquad
 522       tbiaux(1,5) = nbtetr
 523       tbiaux(1,6) = nbhexa
 524       tbiaux(1,7) = nbpent
 525       tbiaux(1,8) = nbpyra
 526       tbiaux(2,1) = 2
 527       if ( degre.eq.1 ) then
 528         tbiaux(2,2) = 4
 529       else
 530         tbiaux(2,2) = 5
 531       endif
 532       do 51 , iaux = 3 , 8
 533         tbiaux(2,iaux) = tbiaux(2,iaux-1) + 3
 534    51 continue
 535 c
 536       iaux = 1
 537       jaux = 0
 538       if ( langue.eq.1 ) then
 539 c                 12345678901234567890123456789012
 540         saux32 = 'dans le fichier                 '
 541       else
 542         saux32 = 'in the file                     '
 543       endif
 544 #ifdef _DEBUG_HOMARD_
 545       write (ulsort,texte(langue,3)) 'UTINMA', nompro
 546 #endif
 547       call utinma ( iaux, saux32,
 548      >              sdimca, mdimca, degre,
 549      >              nbnoto,   jaux,  jaux, jaux,
 550      >              jaux, jaux,
 551      >              iaux, nbelem,
 552      >              nbmapo, tbiaux(1,2), tbiaux(1,3), tbiaux(1,4),
 553      >              tbiaux(1,5), tbiaux(1,6), tbiaux(1,8), tbiaux(1,7),
 554      >              jaux,
 555      >              nbmane, nbmaae, nbmafe,
 556      >              ulsort, langue, codret)
 557 c
 558       write(ulsort,texte(langue,29)) nbfmed
 559       write(ulsort,texte(langue,31)) ngrouc
 560 c
 561       if ( nbequi.ne.0 ) then
 562         write(ulsort,texte(langue,41)) nbequi
 563         write(ulsort,texte(langue,42)) mess14(langue,3,-1), nbeqno
 564         tbiaux(2,1) = 0
 565         tbiaux(2,2) = 1
 566         tbiaux(2,3) = 2
 567         tbiaux(2,4) = 4
 568         tbiaux(3,1) = nbeqmp
 569         tbiaux(3,2) = nbeqar
 570         tbiaux(3,3) = nbeqtr
 571         tbiaux(3,4) = nbeqqu
 572         do 53 , iaux = 1 , 4
 573           if ( tbiaux(1,iaux).gt.0 ) then
 574             write(ulsort,texte(langue,42))
 575      >            mess14(langue,3,tbiaux(2,iaux)), tbiaux(3,iaux)
 576           endif
 577    53 continue
 578       endif
 579 c
 580       endif
 581 c
 582 c====
 583 c 6. la fin
 584 c====
 585 c
 586       if ( codret.ne.0 ) then
 587 c
 588 #include "envex2.h"
 589 c
 590       write (ulsort,texte(langue,1)) 'Sortie', nompro
 591       write (ulsort,texte(langue,2)) codret
 592 c
 593       endif
 594 c
 595 #ifdef _DEBUG_HOMARD_
 596       write (ulsort,texte(langue,1)) 'Sortie', nompro
 597       call dmflsh (iaux)
 598 #endif
 599 c
 600       end