src/tool/ES_HOMARD/eslmh3.F

   1       subroutine eslmh3 ( idfmed, nomamd,
   2      >                    nhsupe,
   3      >                    nbfmed, natmax, ngrmax,
   4      >                    ulsort, langue, codret)
   5 c
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c  Entree-Sortie : Lecture du Maillage Homard - phase 3
  27 c  -      -        -          -        -              -
  28 c ______________________________________________________________________
  29 c    Attention : esemh0 et eslmh3 doivent evoluer en parallelle
  30 c ______________________________________________________________________
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . idfmed . e   .   1    . identificateur du fichier MED              .
  34 c . nomamd . e   . char64 . nom du maillage MED voulu                  .
  35 c . nhsupe . e   . char8  . informations supplementaires entieres      .
  36 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  37 c . langue . e   .    1   . langue des messages                        .
  38 c .        .     .        . 1 : francais, 2 : anglais                  .
  39 c . codret . es  .    1   . code de retour des modules                 .
  40 c .        .     .        . 0 : pas de probleme                        .
  41 c ______________________________________________________________________
  42 c
  43 c====
  44 c 0. declarations et dimensionnement
  45 c====
  46 c
  47 c 0.1. ==> generalites
  48 c
  49       implicit none
  50       save
  51 c
  52       character*6 nompro
  53       parameter ( nompro = 'ESLMH3' )
  54 c
  55 #include "nblang.h"
  56 #include "consts.h"
  57 c
  58 c 0.2. ==> communs
  59 c
  60 #include "gmenti.h"
  61 c
  62 #include "envex1.h"
  63 c
  64 #include "envada.h"
  65 #include "dicfen.h"
  66 #include "nbfami.h"
  67 #include "nombmp.h"
  68 #include "nombar.h"
  69 #include "nombtr.h"
  70 #include "nombqu.h"
  71 #include "nombno.h"
  72 #include "nombte.h"
  73 #include "nombpy.h"
  74 #include "nombhe.h"
  75 #include "nombpe.h"
  76 #include "nancnb.h"
  77 c
  78 c 0.3. ==> arguments
  79 c
  80       integer*8 idfmed
  81       integer nbfmed, natmax, ngrmax
  82 c
  83       character*8 nhsupe
  84       character*64 nomamd
  85 c
  86       integer ulsort, langue, codret
  87 c
  88 c 0.4. ==> variables locales
  89 c
  90 #include "meddc0.h"
  91 c
  92       integer iaux, jaux, kaux, laux
  93       integer lgnpro
  94       integer codre1, codre2
  95       integer codre0
  96       integer nbprof
  97       integer nbvapr, adlipr
  98 c
  99       character*64 noprof
 100 c
 101       integer nbmess
 102       parameter ( nbmess = 150 )
 103       character*80 texte(nblang,nbmess)
 104 c ______________________________________________________________________
 105 c
 106 c====
 107 c 1. intialisations
 108 c====
 109 c
 110 #include "impr01.h"
 111 c
 112 #ifdef _DEBUG_HOMARD_
 113       write (ulsort,texte(langue,1)) 'Entree', nompro
 114       call dmflsh (iaux)
 115 #endif
 116 c
 117       texte(1,4) = '(/,5x,''Mise a jour des communs'')'
 118 c
 119       texte(2,4) = '(/,5x,''Updating of commons'')'
 120 c
 121 #include "esimpr.h"
 122 c
 123 #include "impr03.h"
 124 c
 125 c====
 126 c 2. Recuperation des parametres essentiels
 127 c====
 128 #ifdef _DEBUG_HOMARD_
 129       write (ulsort,90002) '2. Lecture des profils ; codret', codret
 130 #endif
 131 c 2.1. ==> Nombre de profils
 132 c
 133       if ( codret.eq.0 ) then
 134 c
 135 #ifdef _DEBUG_HOMARD_
 136       write (ulsort,texte(langue,3)) 'MPFNPF', nompro
 137 #endif
 138       call mpfnpf ( idfmed, nbprof, codret )
 139 #ifdef _DEBUG_HOMARD_
 140       write (ulsort,texte(langue,86)) nbprof
 141 #endif
 142 c
 143       endif
 144 c
 145 c 2.2. ==> Parcours des profils
 146 c
 147       do 22 , iaux = 1 , nbprof
 148 c
 149 c 2.2.1. ==> nom et taille du profil a lire
 150 c
 151         if ( codret.eq.0 ) then
 152 c
 153         jaux = iaux
 154 c
 155 #ifdef _DEBUG_HOMARD_
 156       write (ulsort,texte(langue,3)) 'MPFPFI', nompro
 157 #endif
 158         call mpfpfi ( idfmed, jaux, noprof, nbvapr, codret )
 159         if ( codret.ne.0 ) then
 160         write (ulsort,texte(langue,79))
 161         endif
 162 c
 163 #ifdef _DEBUG_HOMARD_
 164         write (ulsort,texte(langue,61)) noprof
 165         write (ulsort,texte(langue,62)) nbvapr
 166 #endif
 167 c
 168         endif
 169 c
 170 c 2.2.2. ==> On ne continue que pour les InfoSupE
 171 c
 172         if ( codret.eq.0 ) then
 173 c
 174         if ( noprof(10:12).ne.'Tab' ) then
 175           goto 22
 176         endif
 177 c
 178         endif
 179 c
 180 c 2.2.3. ==> Allocation du tableau receptacle
 181 c
 182         if ( codret.eq.0 ) then
 183 c
 184         call utlgut ( lgnpro, noprof,
 185      >                ulsort, langue, codret )
 186 c
 187         endif
 188 c
 189         if ( codret.eq.0 ) then
 190 c
 191         call utchen ( noprof(13:lgnpro), jaux, ulsort, langue, codret )
 192 c
 193         endif
 194 c
 195         if ( codret.eq.0 ) then
 196 c
 197         call gmaloj ( nhsupe//'.'//noprof(10:lgnpro) , ' ',
 198      >                nbvapr, adlipr, codre1 )
 199         call gmecat ( nhsupe , jaux, nbvapr, codre2 )
 200 c
 201         codre0 = min ( codre1, codre2 )
 202         codret = max ( abs(codre0), codret,
 203      >                 codre1, codre2 )
 204 c
 205         endif
 206 c
 207 c 2.2.4. ==> Lecture de la liste des valeurs
 208 c
 209         if ( codret.eq.0 ) then
 210 #ifdef _DEBUG_HOMARD_
 211       write (ulsort,texte(langue,3)) 'MPFPRR', nompro
 212 #endif
 213         call mpfprr ( idfmed, noprof, imem(adlipr), codret )
 214 c
 215         endif
 216 c
 217 c 2.2.5. ==> Transfert le cas echeant
 218 c
 219         if ( codret.eq.0 ) then
 220 c
 221 c 2.2.5.1. ==> Tab1 : communs entiers
 222 c
 223         if ( jaux.eq.1 ) then
 224 c
 225           kaux = adlipr - 1
 226 c nombno
 227           nbnois = imem(kaux+1)
 228           nbnoei = imem(kaux+2)
 229           nbnoma = imem(kaux+3)
 230           nbnomp = imem(kaux+4)
 231           nbnop1 = imem(kaux+5)
 232           nbnop2 = imem(kaux+6)
 233           nbnoim = imem(kaux+7)
 234           nbnoto = imem(kaux+8)
 235           nbpnho = imem(kaux+9)
 236           numip1 = imem(kaux+10)
 237           numap1 = imem(kaux+11)
 238           nbnoin = imem(kaux+12)
 239           kaux = kaux + 12
 240 c nombmp
 241           nbmpto = imem(kaux+1)
 242           nbppho = imem(kaux+2)
 243           kaux = kaux + 2
 244 c nombar
 245           nbarac = imem(kaux+1)
 246           nbarde = imem(kaux+2)
 247           nbart2 = imem(kaux+3)
 248           nbarq2 = imem(kaux+4)
 249           nbarq3 = imem(kaux+5)
 250           nbarq5 = imem(kaux+6)
 251           nbarin = imem(kaux+7)
 252           nbarma = imem(kaux+8)
 253           nbarpe = imem(kaux+9)
 254           nbarto = imem(kaux+10)
 255           nbfaar = imem(kaux+11)
 256           nbpaho = imem(kaux+12)
 257           kaux = kaux + 12
 258 c nombtr
 259           nbtrac = imem(kaux+1)
 260           nbtrde = imem(kaux+2)
 261           nbtrt2 = imem(kaux+3)
 262           nbtrq3 = imem(kaux+4)
 263           nbtrhc = imem(kaux+5)
 264           nbtrpc = imem(kaux+6)
 265           nbtrtc = imem(kaux+7)
 266           nbtrma = imem(kaux+8)
 267           nbtrpe = imem(kaux+9)
 268           nbtrto = imem(kaux+10)
 269           nbptho = imem(kaux+11)
 270           nbtrri = imem(kaux+12)
 271           kaux = kaux + 12
 272 c nombqu
 273           nbquac = imem(kaux+1)
 274           nbqude = imem(kaux+2)
 275           nbquma = imem(kaux+3)
 276           nbquq2 = imem(kaux+4)
 277           nbquq5 = imem(kaux+5)
 278           nbqupe = imem(kaux+6)
 279           nbquto = imem(kaux+7)
 280           nbpqho = imem(kaux+8)
 281           nbquri = imem(kaux+9)
 282           kaux = kaux + 9
 283 c nombte
 284           nbteac = imem(kaux+1)
 285           nbtea2 = imem(kaux+2)
 286           nbtea4 = imem(kaux+3)
 287           nbtede = imem(kaux+4)
 288           nbtef4 = imem(kaux+5)
 289           nbteh1 = imem(kaux+6)
 290           nbteh2 = imem(kaux+7)
 291           nbteh3 = imem(kaux+8)
 292           nbteh4 = imem(kaux+9)
 293           nbtep0 = imem(kaux+10)
 294           nbtep1 = imem(kaux+11)
 295           nbtep2 = imem(kaux+12)
 296           nbtep3 = imem(kaux+13)
 297           nbtep4 = imem(kaux+14)
 298           nbtep5 = imem(kaux+15)
 299           nbtedh = imem(kaux+16)
 300           nbtedp = imem(kaux+17)
 301           nbtema = imem(kaux+18)
 302           nbtepe = imem(kaux+19)
 303           nbteto = imem(kaux+20)
 304           nbtecf = imem(kaux+21)
 305           nbteca = imem(kaux+22)
 306           kaux = kaux + 22
 307 c nombhe
 308           nbheac = imem(kaux+1)
 309           nbheco = imem(kaux+2)
 310           nbhede = imem(kaux+3)
 311           nbhedh = imem(kaux+4)
 312           nbhema = imem(kaux+5)
 313           nbhepe = imem(kaux+6)
 314           nbheto = imem(kaux+7)
 315           nbhecf = imem(kaux+8)
 316           nbheca = imem(kaux+9)
 317           kaux = kaux + 9
 318 c nombpe
 319           nbpeac = imem(kaux+1)
 320           nbpeco = imem(kaux+2)
 321           nbpede = imem(kaux+3)
 322           nbpedp = imem(kaux+4)
 323           nbpema = imem(kaux+5)
 324           nbpepe = imem(kaux+6)
 325           nbpeto = imem(kaux+7)
 326           nbpecf = imem(kaux+8)
 327           nbpeca = imem(kaux+9)
 328           kaux = kaux + 9
 329 c nombpy
 330           nbpyac = imem(kaux+1)
 331           nbpyh1 = imem(kaux+2)
 332           nbpyh2 = imem(kaux+3)
 333           nbpyh3 = imem(kaux+4)
 334           nbpyh4 = imem(kaux+5)
 335           nbpyp0 = imem(kaux+6)
 336           nbpyp1 = imem(kaux+7)
 337           nbpyp2 = imem(kaux+8)
 338           nbpyp3 = imem(kaux+9)
 339           nbpyp4 = imem(kaux+10)
 340           nbpyp5 = imem(kaux+11)
 341           nbpydh = imem(kaux+12)
 342           nbpydp = imem(kaux+13)
 343           nbpyma = imem(kaux+14)
 344           nbpype = imem(kaux+15)
 345           nbpyto = imem(kaux+16)
 346           nbpycf = imem(kaux+17)
 347           nbpyca = imem(kaux+18)
 348           kaux = kaux + 18
 349 c nbfami
 350           nbfnoe = imem(kaux+1)
 351           nbfmpo = imem(kaux+2)
 352           nbfare = imem(kaux+3)
 353           nbftri = imem(kaux+4)
 354           nbfqua = imem(kaux+5)
 355           nbftet = imem(kaux+6)
 356           nbfhex = imem(kaux+7)
 357           nbfpyr = imem(kaux+8)
 358           nbfpen = imem(kaux+9)
 359           kaux = kaux + 9
 360 c dicfen
 361           ncffno = imem(kaux+ 1)
 362           ncffmp = imem(kaux+ 2)
 363           ncffar = imem(kaux+ 3)
 364           ncfftr = imem(kaux+ 4)
 365           ncffqu = imem(kaux+ 5)
 366           ncffte = imem(kaux+ 6)
 367           ncffhe = imem(kaux+ 7)
 368           ncffpy = imem(kaux+ 8)
 369           ncffpe = imem(kaux+ 9)
 370           ncefno = imem(kaux+10)
 371           ncefmp = imem(kaux+11)
 372           ncefar = imem(kaux+12)
 373           nceftr = imem(kaux+13)
 374           ncefqu = imem(kaux+14)
 375           nctfno = imem(kaux+15)
 376           nctfmp = imem(kaux+16)
 377           nctfar = imem(kaux+17)
 378           nctftr = imem(kaux+18)
 379           nctfqu = imem(kaux+19)
 380           nctfte = imem(kaux+20)
 381           nctfhe = imem(kaux+21)
 382           nctfpy = imem(kaux+22)
 383           nctfpe = imem(kaux+23)
 384           ncxfno = imem(iaux+24)
 385           ncxfar = imem(iaux+25)
 386           ncxftr = imem(iaux+26)
 387           ncxfqu = imem(iaux+27)
 388           kaux = kaux + 27
 389 c envada
 390           nbiter = imem(kaux+1)
 391           nivinf = imem(kaux+2)
 392           nivsup = imem(kaux+3)
 393           niincf = imem(kaux+4)
 394           nisucf = imem(kaux+5)
 395           kaux = kaux + 5
 396 c
 397 c 2.2.5.2. ==> Tab7 : pointeurs des informations generales
 398 c
 399         elseif ( jaux.eq.7 ) then
 400 c
 401           kaux = nbvapr
 402           call gmecat ( nhsupe , jaux, kaux, codret )
 403 c
 404         endif
 405 c
 406         endif
 407 c
 408    22 continue
 409 c
 410 ccc      write (ulsort,90002) 'nbnoto', nbnoto
 411 ccc      write (ulsort,90002) 'nbmpto', nbmpto
 412 ccc      write (ulsort,90002) 'nbarto', nbarto
 413 ccc      write (ulsort,90002) 'nbtrto', nbtrto
 414 ccc      write (ulsort,90002) 'nbteto', nbteto
 415 ccc      write (ulsort,90002) 'nbquto', nbquto
 416 ccc      write (ulsort,90002) 'nbpyto', nbpyto
 417 ccc      write (ulsort,90002) 'nbheto', nbheto
 418 ccc      write (ulsort,90002) 'nbpeto', nbpeto
 419 c
 420 cgn      call gmprsx (nompro,nhsupe)
 421 c
 422 c 2.3. ==> Archivage
 423 c
 424       if ( codret.eq.0 ) then
 425 c
 426       nancno = nbnoto
 427       nancar = nbarto
 428       nanctr = nbtrto
 429       nancqu = nbquto
 430       nancte = nbteto
 431       nanctf = nbtecf
 432       nancta = nbteca
 433       nanche = nbheto
 434       nanchf = nbhecf
 435       nancha = nbheca
 436       nancpe = nbpeto
 437       nancpf = nbpecf
 438       nancpa = nbpeca
 439       nancpy = nbpyto
 440       nancyf = nbpycf
 441       nancya = nbpyca
 442 c
 443       endif
 444 c
 445 c====
 446 c 3. Recuperation du dimensionnement des familles
 447 c====
 448 #ifdef _DEBUG_HOMARD_
 449       write (ulsort,90002) '3. Lecture des familles ; codret', codret
 450 #endif
 451 c
 452 c 3.1. ==> Nombre de familles
 453 c
 454       if ( codret.eq.0 ) then
 455 c
 456 #ifdef _DEBUG_HOMARD_
 457       write (ulsort,texte(langue,3)) 'MFANFA', nompro
 458 #endif
 459       call mfanfa ( idfmed, nomamd, nbfmed, codret )
 460 c
 461 #ifdef _DEBUG_HOMARD_
 462       write (ulsort,texte(langue,29)) nbfmed
 463 #endif
 464 c
 465       endif
 466 c
 467 c 3.2. ==> Recherche des nombres maximaux de groupe
 468 c
 469       if ( codret.eq.0 ) then
 470 c
 471       natmax = 0
 472       ngrmax = 0
 473 c
 474       do 320 , laux = 1 , nbfmed
 475 c
 476         if ( codret.eq.0 ) then
 477 c
 478 #ifdef _DEBUG_HOMARD_
 479       write (ulsort,texte(langue,3)) 'MFANFG', nompro
 480 #endif
 481         iaux = laux
 482 ccc        call efnatt ( idfmed, nomamd, iaux, jaux, codre1 )
 483         call mfanfg ( idfmed, nomamd, iaux, kaux, codret )
 484 ccc        write (ulsort,90002) 'natt ', jaux
 485 ccc        write (ulsort,90002) 'ngro ', kaux
 486 c
 487         endif
 488 c
 489         if ( codret.eq.0 ) then
 490 c
 491         ngrmax = max ( ngrmax, kaux )
 492 c
 493         endif
 494 c
 495   320 continue
 496 c
 497       endif
 498 ccc      write (ulsort,90002) 'nbfmed', nbfmed
 499 ccc      write (ulsort,90002) 'ngrmax', ngrmax
 500 c
 501 c====
 502 c 4. la fin
 503 c====
 504 c
 505       if ( codret.ne.0 ) then
 506 c
 507 #include "envex2.h"
 508 c
 509       write (ulsort,texte(langue,1)) 'Sortie', nompro
 510       write (ulsort,texte(langue,2)) codret
 511 c
 512       endif
 513 c
 514 #ifdef _DEBUG_HOMARD_
 515       write (ulsort,texte(langue,1)) 'Sortie', nompro
 516       call dmflsh (iaux)
 517 #endif
 518 c
 519       end