src/tool/ES_HOMARD/eslmh1.F

   1       subroutine eslmh1 ( typobs, nomail,
   2      >                    suifro, nocdfr, ncafdg,
   3      >                    ulsort, langue, codret)
   4 c
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c  Entree-Sortie : Lecture du Maillage Homard - phase 1
  26 c  -      -        -          -        -              -
  27 c ______________________________________________________________________
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . typobs . e   . char*8 . mot-cle correspondant a l'objet a lire     .
  31 c . nomail .  s  . char*8 . nom du maillage a lire                     .
  32 c . suifro . es  .   1    . 1 : pas de suivi de frontiere              .
  33 c .        .     .        . 2x : frontiere discrete                    .
  34 c .        .     .        . 3x : frontiere analytique                  .
  35 c .        .     .        . 5x : frontiere cao                         .
  36 c .        .     .        . <0 : le maillage est absent du fichier     .
  37 c . nocdfr .  s  . char*8 . nom de l'objet description de la frontiere .
  38 c . ncafdg .  s  . char*8 . nom de l'objet groupes frontiere           .
  39 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  40 c . langue . e   .    1   . langue des messages                        .
  41 c .        .     .        . 1 : francais, 2 : anglais                  .
  42 c . codret . es  .    1   . code de retour des modules                 .
  43 c .        .     .        . 0 : pas de probleme                        .
  44 c ______________________________________________________________________
  45 c
  46 c====
  47 c 0. declarations et dimensionnement
  48 c====
  49 c
  50 c 0.1. ==> generalites
  51 c
  52       implicit none
  53       save
  54 c
  55       character*6 nompro
  56       parameter ( nompro = 'ESLMH1' )
  57 c
  58 #include "nblang.h"
  59 #include "consts.h"
  60 c
  61 c 0.2. ==> communs
  62 c
  63 #include "gmenti.h"
  64 #include "gmstri.h"
  65 c
  66 #include "dicfen.h"
  67 #include "envex1.h"
  68 #include "envca1.h"
  69 #include "nombmp.h"
  70 #include "nombar.h"
  71 #include "nombtr.h"
  72 #include "nombqu.h"
  73 #include "nombno.h"
  74 #include "nombte.h"
  75 #include "nombpy.h"
  76 #include "nombhe.h"
  77 #include "nombpe.h"
  78 #include "front1.h"
  79 #include "nbutil.h"
  80 c
  81 c 0.3. ==> arguments
  82 c
  83       integer suifro
  84 c
  85       character*8 typobs
  86       character*(*) nomail
  87       character*8 nocdfr, ncafdg
  88 c
  89       integer ulsort, langue, codret
  90 c
  91 c 0.4. ==> variables locales
  92 c
  93 #include "meddc0.h"
  94 c
  95       integer iaux, jaux
  96       integer codre0
  97       integer codre1, codre2
  98       integer lnomai, lnomfi
  99       integer*8 idfmed
 100       integer typnom
 101       integer dimcst, lgnoig, nbnoco
 102       integer natmax, ngrmax
 103       integer lgpeli
 104       integer lnomaf
 105       integer ltrav1, ltrav2
 106       integer ptrav1, ptrav2
 107 c
 108       character*8 ntrav1, ntrav2
 109       character*8 norenu
 110       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 111       character*8 nhtetr, nhhexa, nhpyra, nhpent
 112       character*8 nhelig
 113       character*8 nhvois, nhsupe, nhsups
 114       character*64 nomamd
 115       character*64 nomafr
 116       character*200 nomfic
 117 c
 118       logical exiren
 119 c
 120       integer nbmess
 121       parameter ( nbmess = 150 )
 122       character*80 texte(nblang,nbmess)
 123 c ______________________________________________________________________
 124 c
 125 c====
 126 c 1. intialisations
 127 c====
 128 c
 129 #include "impr01.h"
 130 c
 131 #ifdef _DEBUG_HOMARD_
 132       write (ulsort,texte(langue,1)) 'Entree', nompro
 133       call dmflsh (iaux)
 134 #endif
 135 c
 136       texte(1,4) = '(5x,''Lecture du maillage '',a,'' sur le fichier'')'
 137 c
 138       texte(2,4) = '(5x,''Readings of mesh '',a,'' on file'')'
 139 c
 140 #include "impr03.h"
 141 c
 142 #include "esimpr.h"
 143 c
 144       codret = 0
 145 c
 146 c====
 147 c 2. nom du maillage et du fichier
 148 c====
 149 #ifdef _DEBUG_HOMARD_
 150       write (ulsort,90002) '2. maillage/fichier ; codret', codret
 151 #endif
 152 c
 153       if ( codret.eq.0 ) then
 154 c
 155       iaux = 0
 156       jaux = 1
 157       call utfino ( typobs, iaux, nomfic, lnomfi,
 158      >              jaux,
 159      >              ulsort, langue, codret )
 160 c
 161       endif
 162 c
 163       if ( codret.eq.0 ) then
 164 c
 165       iaux = 0
 166 #ifdef _DEBUG_HOMARD_
 167       write (ulsort,texte(langue,3)) 'UTOSNO', nompro
 168 #endif
 169       call utosno ( typobs, nomail, iaux, ulsort, langue, codret )
 170 c
 171       endif
 172 c
 173       if ( codret.eq.0 ) then
 174 c
 175       call utlgut ( lnomai, nomail,
 176      >              ulsort, langue, codret )
 177 c
 178       endif
 179 c
 180       if ( codret.eq.0 ) then
 181       write (ulsort,texte(langue,4)) nomail(1:lnomai)
 182       write (ulsort,*) '    '//nomfic(1:lnomfi)
 183       endif
 184 c
 185 c====
 186 c 3. ouverture du fichier et lectures preliminaires
 187 c====
 188 #ifdef _DEBUG_HOMARD_
 189       write (ulsort,90002) '3. ouverture du fichier ; codret', codret
 190 #endif
 191 c
 192 c 3.1. ==> Ouverture du fichier
 193 c
 194       if ( codret.eq.0 ) then
 195 c
 196 #ifdef _DEBUG_HOMARD_
 197       iaux = 3
 198 #else
 199       iaux = 1
 200 #endif
 201 #ifdef _DEBUG_HOMARD_
 202       write (ulsort,texte(langue,3)) 'ESOUVL', nompro
 203 #endif
 204       call esouvl ( idfmed, nomfic(1:lnomfi), iaux,
 205      >              ulsort, langue, codret )
 206       if ( codret.ne.0 ) then
 207         codret = 1
 208       endif
 209 c
 210       endif
 211 c
 212 c 3.2. ==> Lectures de base
 213 c
 214       if ( codret.eq.0 ) then
 215 c
 216 #ifdef _DEBUG_HOMARD_
 217       write (ulsort,texte(langue,3)) 'ESLMH2', nompro
 218 #endif
 219       call eslmh2 ( idfmed,
 220      >              nomail, lnomai,
 221      >                sdim,   mdim,
 222      >               degre, maconf, homolo, hierar,
 223      >              rafdef, nbmane, typcca, typsfr, maextr,
 224      >              mailet,
 225      >              dimcst, lgnoig, nbnoco,
 226      >              sdimca, mdimca,
 227      >              exiren, lgpeli,
 228      >              suifro, nomafr, lnomaf,
 229      >              ulsort, langue, codret)
 230 c
 231       endif
 232 c
 233 c====
 234 c 4. allocation de la tete du maillage HOMARD
 235 c====
 236 #ifdef _DEBUG_HOMARD_
 237       write (ulsort,90002) '4. allocation de la tete ; codret', codret
 238 #endif
 239 c
 240       if ( codret.eq.0 ) then
 241 c
 242       if ( exiren ) then
 243         iaux = 1
 244       else
 245         iaux = 2
 246       endif
 247       typnom = 1
 248 #ifdef _DEBUG_HOMARD_
 249       write (ulsort,texte(langue,3)) 'UTAHMA', nompro
 250 #endif
 251       call utahma ( nomail, typnom, iaux,
 252      >                sdim,   mdim,  degre, mailet, maconf,
 253      >              homolo, hierar, rafdef,
 254      >              nbmane, typcca, typsfr, maextr,
 255      >              norenu,
 256      >              nhnoeu, nhmapo, nharet,
 257      >              nhtria, nhquad,
 258      >              nhtetr, nhhexa, nhpyra, nhpent,
 259      >              nhelig,
 260      >              nhvois, nhsupe, nhsups,
 261      >              ulsort, langue, codret )
 262 c
 263       endif
 264 c
 265 c====
 266 c 5. Recuperation des communs
 267 c====
 268 #ifdef _DEBUG_HOMARD_
 269       write (ulsort,90002) '5. Recuperation communs ; codret', codret
 270 #endif
 271 c
 272       if ( codret.eq.0 ) then
 273 c
 274       nomamd = blan64
 275       nomamd(1:8) = nomail
 276 c
 277 #ifdef _DEBUG_HOMARD_
 278       write (ulsort,texte(langue,3)) 'ESLMH3', nompro
 279 #endif
 280       call eslmh3 ( idfmed, nomamd,
 281      >              nhsupe,
 282      >              nbfmed, natmax, ngrmax,
 283      >              ulsort, langue, codret)
 284 c
 285       endif
 286 c
 287 c====
 288 c 6. tableaux de travail
 289 c    On doit tenir compte des caracteristiques des familles pour
 290 c    le dimensionnement du tableau tbsaux
 291 c====
 292 #ifdef _DEBUG_HOMARD_
 293       write (ulsort,90002) '6. tableaux de travail ; codret', codret
 294 #endif
 295 c
 296       if ( codret.eq.0 ) then
 297 c
 298 #ifdef _DEBUG_HOMARD_
 299       write (ulsort,90002) 'nbnoto', nbnoto
 300       write (ulsort,90002) 'nbmpto', nbmpto
 301       write (ulsort,90002) 'nbarto', nbarto
 302       write (ulsort,90002) 'nbtrto', nbtrto
 303       write (ulsort,90002) 'nbquto', nbquto
 304       write (ulsort,90002) 'nbteto, nbtecf, nbteca',
 305      >                      nbteto, nbtecf, nbteca
 306       write (ulsort,90002) 'nbheto, nbhecf, nbheca',
 307      >                      nbheto, nbhecf, nbheca
 308       write (ulsort,90002) 'nbpyto, nbpycf, nbpyca',
 309      >                      nbpyto, nbpycf, nbpyca
 310       write (ulsort,90002) 'nbpeto, nbpecf, nbpeca',
 311      >                      nbpeto, nbpecf, nbpeca
 312       write (ulsort,90002) 'nbfmed', nbfmed
 313       write (ulsort,90002) 'ngrmax', ngrmax
 314       write (ulsort,90002) 'lgpeli', lgpeli
 315       write (ulsort,90002) 'sfsdim', sfsdim
 316       write (ulsort,90002) 'sfnbso', sfnbso
 317       write (ulsort,90002) 'sfnbse', sfnbse
 318 #endif
 319 c
 320       ltrav1 = max ( 4*nbnoto,
 321      >               nbmpto, 5*nbarto, 5*nbtrto, 5*nbquto,
 322      >               6*nbteto, 2*nbteca,
 323      >               7*nbpyto, 3*nbpyca,
 324      >               8*nbheto, 6*nbheca,
 325      >               5*nbpeto, 4*nbpeca,
 326      >               lgpeli,
 327      >               sfnbso )
 328       call gmalot ( ntrav1, 'entier  ', ltrav1   , ptrav1, codre1 )
 329       ltrav2 = 25*( max ( nctfno, nctfmp, nctfar, nctftr, nctfqu,
 330      >                    nctfte, nctfpy, nctfhe, nctfpe, 30 ) + 1 )
 331       ltrav2 = max ( ltrav2, 25*natmax+10*ngrmax )
 332       call gmalot ( ntrav2, 'chaine  ', ltrav2   , ptrav2, codre2 )
 333 c
 334       codre0 = min ( codre1, codre2 )
 335       codret = max ( abs(codre0), codret,
 336      >               codre1, codre2 )
 337 c
 338       endif
 339 c
 340 c====
 341 c 7. Lecture des noeuds
 342 c====
 343 #ifdef _DEBUG_HOMARD_
 344       write (ulsort,90002) '7. Lecture des noeuds ; codret', codret
 345 #endif
 346 c
 347       if ( codret.eq.0 ) then
 348 c
 349 #ifdef _DEBUG_HOMARD_
 350       write (ulsort,texte(langue,3)) 'ESLENO', nompro
 351 #endif
 352       call esleno ( idfmed, nomamd,
 353      >              nhnoeu,
 354      >              dimcst, lgnoig, nbnoco,
 355      >              ltrav1, imem(ptrav1),
 356      >              ulsort, langue, codret)
 357 c
 358       endif
 359 c
 360 c====
 361 c 8. Lecture des entites mailles
 362 c====
 363 #ifdef _DEBUG_HOMARD_
 364       write (ulsort,90002) '8. Lecture des mailles ; codret', codret
 365 #endif
 366 c
 367       if ( codret.eq.0 ) then
 368 c
 369 #ifdef _DEBUG_HOMARD_
 370       write (ulsort,texte(langue,3)) 'ESLEEN', nompro
 371 #endif
 372       call esleen ( idfmed, nomamd,
 373      >              nhmapo, nharet, nhtria, nhquad,
 374      >              nhtetr, nhhexa, nhpyra, nhpent,
 375      >              ltrav1, imem(ptrav1),
 376      >              ulsort, langue, codret )
 377 c
 378       endif
 379 c
 380 c====
 381 c 9. Les renumerotations
 382 c====
 383 #ifdef _DEBUG_HOMARD_
 384       write (ulsort,90002) '9. Les renumerotations ; codret', codret
 385 #endif
 386 c
 387       if ( exiren ) then
 388 c
 389       if ( codret.eq.0 ) then
 390 c
 391 #ifdef _DEBUG_HOMARD_
 392       write (ulsort,texte(langue,3)) 'ESLMH4', nompro
 393 #endif
 394       call eslmh4 ( idfmed,
 395      >              nomail,
 396      >              ulsort, langue, codret)
 397 c
 398       endif
 399 c
 400       endif
 401 c
 402 c====
 403 c 10. Lecture des familles
 404 c====
 405 #ifdef _DEBUG_HOMARD_
 406       write (ulsort,90002) '10. les familles ; codret', codret
 407 #endif
 408 c
 409       if ( codret.eq.0) then
 410 c
 411 #ifdef _DEBUG_HOMARD_
 412       write (ulsort,texte(langue,3)) 'ESLEFE', nompro
 413 #endif
 414       call eslefe ( idfmed, nomamd,
 415      >              nhnoeu, nhmapo, nharet, nhtria, nhquad,
 416      >              nhtetr, nhhexa, nhpyra, nhpent,
 417      >              nhsups,
 418      >              ltrav2, smem(ptrav2),
 419      >              ulsort, langue, codret )
 420 c
 421       endif
 422 c
 423 c====
 424 c 11. Lecture des elements ignores
 425 c====
 426 #ifdef _DEBUG_HOMARD_
 427       write (ulsort,90002) '10. Elements ignores ; codret', codret
 428 #endif
 429 c
 430       if ( lgpeli.gt.0 ) then
 431 c
 432         if ( codret.eq.0 ) then
 433 c
 434 #ifdef _DEBUG_HOMARD_
 435       write (ulsort,texte(langue,3)) 'ESLMH6', nompro
 436 #endif
 437         call eslmh6 ( idfmed,
 438      >                nhelig,
 439      >                imem(ptrav1),
 440      >                ulsort, langue, codret)
 441 c
 442         endif
 443 c
 444       endif
 445 c
 446 c====
 447 c 11. Lecture de l'eventuelle frontiere discrete
 448 c====
 449 #ifdef _DEBUG_HOMARD_
 450       write (ulsort,90002) '11. Frontiere discrete ; codret', codret
 451 #endif
 452 c
 453       if ( mod(suifro,2).eq.0 ) then
 454 c
 455         if ( lnomaf.gt.0 ) then
 456 c
 457           if ( codret.eq.0 ) then
 458 c
 459 #ifdef _DEBUG_HOMARD_
 460       write (ulsort,texte(langue,3)) 'ESLMH7', nompro
 461 #endif
 462           call eslmh7 ( idfmed,
 463      >                  nocdfr, ncafdg,
 464      >                  ltrav1, imem(ptrav1), ltrav2, smem(ptrav2),
 465      >                  nomafr, lnomaf,
 466      >                  ulsort, langue, codret )
 467 c
 468           endif
 469 c
 470         else
 471 c
 472           suifro = -abs(suifro)
 473 c
 474         endif
 475 c
 476       endif
 477 c
 478 c====
 479 c 12. Fermeture du fichier
 480 c====
 481 #ifdef _DEBUG_HOMARD_
 482       write (ulsort,90002) '12. Fermeture du fichier ; codret', codret
 483 #endif
 484 c
 485       if ( codret.eq.0 ) then
 486 c
 487 #ifdef _DEBUG_HOMARD_
 488       write (ulsort,texte(langue,3)) 'MFICLO', nompro
 489 #endif
 490       call mficlo ( idfmed, codret )
 491       if ( codret.ne.0 ) then
 492         write (ulsort,texte(langue,8)) nomfic(1:lnomfi)
 493         write (ulsort,texte(langue,10))
 494       endif
 495 c
 496       endif
 497 c
 498 #ifdef _DEBUG_HOMARD_
 499       if ( codret.eq.0 ) then
 500       call gmprsx ( nompro, nomail )
 501       endif
 502 #endif
 503 c
 504 c====
 505 c 13. la fin
 506 c====
 507 c
 508       if ( codret.ne.0 ) then
 509 c
 510 #include "envex2.h"
 511 c
 512       write (ulsort,texte(langue,1)) 'Sortie', nompro
 513       write (ulsort,texte(langue,2)) codret
 514       write (ulsort,texte(langue,8)) nomfic(1:lnomfi)
 515 c
 516       endif
 517 c
 518 #ifdef _DEBUG_HOMARD_
 519       write (ulsort,texte(langue,1)) 'Sortie', nompro
 520       call dmflsh (iaux)
 521 #endif
 522 c
 523       end