src/tool/ES_HOMARD/eslmho.F

   1       subroutine eslmho ( typobs, nrosec, nretap, nrsset,
   2      >                    nomail, typecc,
   3      >                    suifro, nocdfr, ncafdg,
   4      >                    ulsort, langue, codret)
   5 c
   6 c  on peut ne stocker que des listes restreintes pour les
   7 c  homologues si on veut optimiser le stockage
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c  Entree-Sortie : Lecture du Maillage HOmard
  29 c  -      -        -          -        --
  30 c ______________________________________________________________________
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . typobs . e   . char*8 . mot-cle correspondant a l'objet a lire     .
  34 c . nrosec . e   .   1    . numero de section pour les mesures de temps.
  35 c . nretap . e   .   1    . numero d'etape                             .
  36 c . nrsset . e   .   1    . numero de sous-etape                       .
  37 c . nomail .   s . char*8 . nom de l'objet maillage homard lu          .
  38 c . typecc .   s .   1    . type de code de calcul associe             .
  39 c . suifro . e   .   1    . 1 : pas de suivi de frontiere              .
  40 c .        .     .        . 2x : frontiere discrete                    .
  41 c .        .     .        . 3x : frontiere analytique                  .
  42 c .        .     .        . 5x : frontiere cao                         .
  43 c . nocdfr .  s  . char8  . nom de l'objet description de la frontiere .
  44 c . ncafdg .  s  . char*8 . nom de l'objet groupes frontiere           .
  45 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  46 c . langue . e   .    1   . langue des messages                        .
  47 c .        .     .        . 1 : francais, 2 : anglais                  .
  48 c . codret . es  .    1   . code de retour des modules                 .
  49 c .        .     .        . 0 : pas de 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 = 'ESLMHO' )
  63 c
  64 #include "nblang.h"
  65 c
  66 c 0.2. ==> communs
  67 c
  68 #include "envex1.h"
  69 c
  70 #include "nomber.h"
  71 #include "nombar.h"
  72 #include "envca1.h"
  73 c
  74 c 0.3. ==> arguments
  75 c
  76       character*8 typobs
  77 c
  78       integer nrosec, nretap, nrsset
  79       integer typecc
  80       integer suifro
  81 c
  82       character*8 nomail
  83       character*8 nocdfr
  84       character*8 ncafdg
  85 c
  86       integer ulsort, langue, codret
  87 c
  88 c 0.4. ==> variables locales
  89 c
  90       integer codava
  91 c
  92       integer numead
  93       integer voarno, vofaar, vovoar, vovofa
  94       integer ppovos, pvoiso
  95       integer pposif, pfacar
  96       integer adnohn
  97       integer admphn
  98       integer adarhn
  99       integer adtrhn
 100       integer adquhn
 101       integer adtehn
 102       integer adhehn
 103       integer adpyhn
 104       integer adpehn
 105       integer iaux, jaux, kaux
 106       integer codre1
 107 c
 108       character*6 saux
 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 c
 115       logical exiren
 116 c
 117       integer nbmess
 118       parameter ( nbmess = 10 )
 119       character*80 texte(nblang,nbmess)
 120 c ______________________________________________________________________
 121 c
 122 c====
 123 c 1. les initialisations
 124 c====
 125 c
 126       codava = codret
 127 c
 128 c=======================================================================
 129       if ( codava.eq.0 ) then
 130 c=======================================================================
 131 c
 132 c 1.1. ==> le debut des mesures de temps
 133 c
 134       if ( nrosec.gt.0 ) then
 135         call gtdems (nrosec)
 136       endif
 137 c
 138 c 1.2. ==> les messages
 139 c
 140 #include "impr01.h"
 141 c
 142 #ifdef _DEBUG_HOMARD_
 143       write (ulsort,texte(langue,1)) 'Entree', nompro
 144       call dmflsh (iaux)
 145 #endif
 146 c
 147       texte(1,4) = '(/,a6,'' RECUPERATION DU MAILLAGE HOMARD'')'
 148       texte(1,5) = '(38(''=''),/)'
 149       texte(1,6) = '(''Mot-cle : '',a8)'
 150 c
 151       texte(2,4) = '(/,a6,'' READINGS OF HOMARD MESH'')'
 152       texte(2,5) = '(30(''=''),/)'
 153       texte(2,6) = '(''Keyword : '',a8)'
 154 c
 155       call utcvne ( nretap, nrsset, saux, iaux, codret )
 156 c
 157 c 1.5. ==> le titre
 158 c
 159       write (ulsort,texte(langue,4)) saux
 160       write (ulsort,texte(langue,5))
 161 c
 162 #include "impr03.h"
 163 c
 164 c====
 165 c 2. Lecture du maillage
 166 c====
 167 c 2.1. ==> Lecture
 168 c
 169 #ifdef _DEBUG_HOMARD_
 170       write (ulsort,texte(langue,3)) 'ESLMH1', nompro
 171 #endif
 172       call eslmh1 ( typobs, nomail,
 173      >              suifro, nocdfr, ncafdg,
 174      >              ulsort, langue, codret)
 175 c
 176 c 2.2. ==> Les structures
 177 c
 178       if ( codret.eq.0 ) then
 179 c
 180 #ifdef _DEBUG_HOMARD_
 181       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 182 #endif
 183       call utnomh ( nomail,
 184      >                sdim,   mdim,
 185      >               degre, maconf, homolo, hierar,
 186      >              rafdef, nbmane, typcca, typsfr, maextr,
 187      >              mailet,
 188      >              norenu,
 189      >              nhnoeu, nhmapo, nharet,
 190      >              nhtria, nhquad,
 191      >              nhtetr, nhhexa, nhpyra, nhpent,
 192      >              nhelig,
 193      >              nhvois, nhsupe, nhsups,
 194      >              ulsort, langue, codret)
 195 c
 196       endif
 197 c
 198       if ( codret.eq.0 ) then
 199       typecc = typcca
 200       endif
 201 c
 202 c====
 203 c 3. Reconstitution des informations supprimees a l'ecriture
 204 c====
 205 #ifdef _DEBUG_HOMARD_
 206       write (ulsort,90002) '3. Reconstitution ; codret', codret
 207 #endif
 208 c
 209 c 3.1. ==> les parentes
 210 c
 211 c 3.1.1. ==> filles des aretes
 212 c
 213       if ( codret.eq.0 ) then
 214 c
 215 #ifdef _DEBUG_HOMARD_
 216       write (ulsort,texte(langue,3)) 'UTMFAR', nompro
 217 #endif
 218       call utmfar ( nomail, ulsort, langue, codret)
 219 c
 220       endif
 221 c
 222 c 3.1.2. ==> filles des faces
 223 c
 224       if ( codret.eq.0 ) then
 225 c
 226 #ifdef _DEBUG_HOMARD_
 227       write (ulsort,texte(langue,3)) 'UTMFFA', nompro
 228 #endif
 229       call utmffa ( nomail, ulsort, langue, codret)
 230 c
 231       endif
 232 c
 233 c 3.1.3. ==> fils des volumes
 234 c
 235       if ( codret.eq.0 ) then
 236 c
 237 #ifdef _DEBUG_HOMARD_
 238       write (ulsort,texte(langue,3)) 'UTMFVO', nompro
 239 #endif
 240       call utmfvo ( nomail, ulsort, langue, codret)
 241 c
 242 cgn      call gmprsx(nompro,nhtetr//'.Mere')
 243 cgn      call gmprsx(nompro,nhhexa//'.Fille')
 244 cgn      call gmprsx(nompro,nhhexa//'.InfoSup2')
 245 c
 246       endif
 247 c
 248 #ifdef _DEBUG_HOMARD_
 249       write (ulsort,90002) 'Apres 3.1. parentes : codret', codret
 250 #endif
 251 c
 252 c 3.2. ==> les voisinages
 253 c
 254       if ( codret.eq.0 ) then
 255 c
 256       voarno = 1
 257       vofaar = 1
 258       vovoar = 0
 259       vovofa = 1
 260 c
 261 #ifdef _DEBUG_HOMARD_
 262       write (ulsort,texte(langue,3)) 'UTVOIS', nompro
 263 #endif
 264       call utvois ( nomail, nhvois,
 265      >              voarno, vofaar, vovoar, vovofa,
 266      >              ppovos, pvoiso,
 267      >              nbfaar, pposif, pfacar,
 268      >              ulsort, langue, codret )
 269 c
 270 #ifdef _DEBUG_HOMARD_
 271       write (ulsort,90002) 'Apres 3.2. voisinages : codret', codret
 272 #endif
 273 c
 274       endif
 275 c
 276 c 3.3. ==> la renumerotation
 277 c
 278 c 3.3.1. ==> existe-t-il une renumerotation ?
 279 c            attention : il faut utiliser le nom compose, car si la
 280 c                        structure n'existe pas, norenu vaut 'Indefini'
 281 c
 282       if ( codret.eq.0 ) then
 283 c
 284       call gmobal ( nomail//'.RenuMail', codre1 )
 285       if ( codre1.eq.1 ) then
 286         exiren = .true.
 287       elseif ( codre1.eq.0 ) then
 288         exiren = .false.
 289       else
 290         codret = 1
 291       endif
 292 c
 293 #ifdef _DEBUG_HOMARD_
 294         write (ulsort,90002) 'Apres 3.3.1 : codret', codret
 295 #endif
 296 c
 297       endif
 298 c
 299 c 3.3.2. ==> reactualisation des communs en attendant une vraie
 300 c            exploitation de la structure partout
 301 c
 302       if ( exiren ) then
 303 c
 304 #ifdef _DEBUG_HOMARD_
 305       if ( codret.eq.0 ) then
 306       call gmprsx (nompro, norenu )
 307       endif
 308 #endif
 309 c
 310       if ( codret.eq.0 ) then
 311 c
 312 #ifdef _DEBUG_HOMARD_
 313       write (ulsort,texte(langue,3)) 'UTRE03_no', nompro
 314 #endif
 315       iaux = -1
 316       jaux = 30
 317       call utre03 ( iaux, jaux, norenu,
 318      >              renoac, renoto, adnohn,   kaux,
 319      >              ulsort, langue, codret)
 320 c
 321       endif
 322 c
 323       if ( codret.eq.0 ) then
 324 c
 325 #ifdef _DEBUG_HOMARD_
 326       write (ulsort,texte(langue,3)) 'UTRE03_mp', nompro
 327 #endif
 328       iaux = 0
 329       jaux = -30
 330       call utre03 ( iaux, jaux, norenu,
 331      >              rempac, rempto, admphn,   kaux,
 332      >              ulsort, langue, codret)
 333 c
 334       endif
 335 c
 336       if ( codret.eq.0 ) then
 337 c
 338 #ifdef _DEBUG_HOMARD_
 339       write (ulsort,texte(langue,3)) 'UTRE03_ar', nompro
 340 #endif
 341       iaux = 1
 342       jaux = -30
 343       call utre03 ( iaux, jaux, norenu,
 344      >              rearac, rearto, adarhn,   kaux,
 345      >              ulsort, langue, codret)
 346 c
 347       endif
 348 c
 349       if ( codret.eq.0 ) then
 350 c
 351 #ifdef _DEBUG_HOMARD_
 352       write (ulsort,texte(langue,3)) 'UTRE03_tr', nompro
 353 #endif
 354       iaux = 2
 355       jaux = -30
 356       call utre03 ( iaux, jaux, norenu,
 357      >              retrac, retrto, adtrhn,   kaux,
 358      >              ulsort, langue, codret)
 359 c
 360       endif
 361 c
 362       if ( codret.eq.0 ) then
 363 c
 364 #ifdef _DEBUG_HOMARD_
 365       write (ulsort,texte(langue,3)) 'UTRE03_te', nompro
 366 #endif
 367       iaux = 3
 368       jaux = -30
 369       call utre03 ( iaux, jaux, norenu,
 370      >              reteac, reteto, adtehn,   kaux,
 371      >              ulsort, langue, codret)
 372 c
 373       endif
 374 c
 375       if ( codret.eq.0 ) then
 376 c
 377 #ifdef _DEBUG_HOMARD_
 378       write (ulsort,texte(langue,3)) 'UTRE03_qu', nompro
 379 #endif
 380       iaux = 4
 381       jaux = -30
 382       call utre03 ( iaux, jaux, norenu,
 383      >              requac, requto, adquhn,   kaux,
 384      >              ulsort, langue, codret)
 385 c
 386       endif
 387 c
 388       if ( codret.eq.0 ) then
 389 c
 390 #ifdef _DEBUG_HOMARD_
 391       write (ulsort,texte(langue,3)) 'UTRE03_py', nompro
 392 #endif
 393       iaux = 5
 394       jaux = -30
 395       call utre03 ( iaux, jaux, norenu,
 396      >              repyac, repyto, adpyhn,   kaux,
 397      >              ulsort, langue, codret)
 398 c
 399       endif
 400 c
 401       if ( codret.eq.0 ) then
 402 c
 403 #ifdef _DEBUG_HOMARD_
 404       write (ulsort,texte(langue,3)) 'UTRE03_he', nompro
 405 #endif
 406       iaux = 6
 407       jaux = -30
 408       call utre03 ( iaux, jaux, norenu,
 409      >              reheac, reheto, adhehn,   kaux,
 410      >              ulsort, langue, codret)
 411 c
 412       endif
 413 c
 414       if ( codret.eq.0 ) then
 415 c
 416 #ifdef _DEBUG_HOMARD_
 417       write (ulsort,texte(langue,3)) 'UTRE03_pe', nompro
 418 #endif
 419       iaux = 7
 420       jaux = -30
 421       call utre03 ( iaux, jaux, norenu,
 422      >              repeac, repeto, adpehn,   kaux,
 423      >              ulsort, langue, codret)
 424 c
 425       endif
 426 c
 427       endif
 428 c
 429 #ifdef _DEBUG_HOMARD_
 430       write (ulsort,90002) 'Apres 3.3.2 : codret', codret
 431 #endif
 432 c
 433 c 3.3.3. ==> creation des tableaux reciproques
 434 c
 435       if ( codret.eq.0 ) then
 436 c
 437       if ( exiren ) then
 438 c
 439       if ( codret.eq.0 ) then
 440 c
 441 #ifdef _DEBUG_HOMARD_
 442       write (ulsort,texte(langue,3)) 'ESLMH5_no', nompro
 443 #endif
 444       iaux = -1
 445       call eslmh5 ( iaux, norenu, renoto, renoac, adnohn,
 446      >              ulsort, langue, codret)
 447 c
 448       endif
 449 c
 450       if ( codret.eq.0 ) then
 451 c
 452 #ifdef _DEBUG_HOMARD_
 453       write (ulsort,texte(langue,3)) 'ESLMH5_mp', nompro
 454 #endif
 455       iaux = 0
 456       call eslmh5 ( iaux, norenu, rempto, rempac, admphn,
 457      >              ulsort, langue, codret)
 458 c
 459       endif
 460 c
 461       if ( codret.eq.0 ) then
 462 c
 463 #ifdef _DEBUG_HOMARD_
 464       write (ulsort,texte(langue,3)) 'ESLMH5_ar', nompro
 465 #endif
 466       iaux = 1
 467       call eslmh5 ( iaux, norenu, rearto, rearac, adarhn,
 468      >              ulsort, langue, codret)
 469 c
 470       endif
 471 c
 472       if ( codret.eq.0 ) then
 473 c
 474 #ifdef _DEBUG_HOMARD_
 475       write (ulsort,texte(langue,3)) 'ESLMH5_tr', nompro
 476 #endif
 477       iaux = 2
 478       call eslmh5 ( iaux, norenu, retrto, retrac, adtrhn,
 479      >              ulsort, langue, codret)
 480 c
 481       endif
 482 c
 483       if ( codret.eq.0 ) then
 484 c
 485 #ifdef _DEBUG_HOMARD_
 486       write (ulsort,texte(langue,3)) 'ESLMH5_te', nompro
 487 #endif
 488       iaux = 3
 489       call eslmh5 ( iaux, norenu, reteto, reteac, adtehn,
 490      >              ulsort, langue, codret)
 491 c
 492       endif
 493 c
 494       if ( codret.eq.0 ) then
 495 c
 496 #ifdef _DEBUG_HOMARD_
 497       write (ulsort,texte(langue,3)) 'ESLMH5_qu', nompro
 498 #endif
 499       iaux = 4
 500       call eslmh5 ( iaux, norenu, requto, requac, adquhn,
 501      >              ulsort, langue, codret)
 502 c
 503       endif
 504 c
 505       if ( codret.eq.0 ) then
 506 c
 507 #ifdef _DEBUG_HOMARD_
 508       write (ulsort,texte(langue,3)) 'ESLMH5_py', nompro
 509 #endif
 510       iaux = 5
 511       call eslmh5 ( iaux, norenu, repyto, repyac, adpyhn,
 512      >              ulsort, langue, codret)
 513 c
 514       endif
 515 c
 516       if ( codret.eq.0 ) then
 517 c
 518 #ifdef _DEBUG_HOMARD_
 519       write (ulsort,texte(langue,3)) 'ESLMH5_he', nompro
 520 #endif
 521       iaux = 6
 522       call eslmh5 ( iaux, norenu, reheto, reheac, adhehn,
 523      >              ulsort, langue, codret)
 524 c
 525       endif
 526 c
 527       if ( codret.eq.0 ) then
 528 c
 529 #ifdef _DEBUG_HOMARD_
 530       write (ulsort,texte(langue,3)) 'ESLMH5_pe', nompro
 531 #endif
 532       iaux = 7
 533       call eslmh5 ( iaux, norenu, repeto, repeac, adpehn,
 534      >              ulsort, langue, codret)
 535 c
 536       endif
 537 c
 538       endif
 539 c
 540       endif
 541 c
 542 c====
 543 c 5. meres adoptives des faces pour la non conformite initiale
 544 c    Il faut le faire seulement maintenant, une fois que toutes les
 545 c    autres grandeurs ont ete initialisees
 546 c====
 547 #ifdef _DEBUG_HOMARD_
 548       write (ulsort,90002) '5. meres adoptives ; codret', codret
 549 #endif
 550 c
 551       if ( ( maconf.eq.-2 ) .or. ( maconf.ge.1 ) ) then
 552 c
 553         if ( codret.eq.0 ) then
 554 c
 555 #ifdef _DEBUG_HOMARD_
 556         write (ulsort,texte(langue,3)) 'UTNC08', nompro
 557 #endif
 558         call utnc08 ( nharet, nhtria, nhquad, nhvois,
 559      >                numead,
 560      >                ulsort, langue, codret )
 561 c
 562         endif
 563 c
 564       endif
 565 c
 566 c====
 567 c 6. verification de la conformite
 568 c    les messages sont toujours imprimes
 569 c====
 570 #ifdef _DEBUG_HOMARD_
 571       write (ulsort,90002) '6. verification conformite ; codret', codret
 572 #endif
 573 c
 574       if ( codret.eq.0 ) then
 575 c
 576       iaux = 1
 577 c
 578 #ifdef _DEBUG_HOMARD_
 579       write (ulsort,texte(langue,3)) 'UTCOMA', nompro
 580 #endif
 581       call utcoma ( nomail,
 582      >              iaux,
 583      >              ulsort, langue, codret )
 584 c
 585       endif
 586 c
 587 c====
 588 c 7. la fin
 589 c====
 590 c
 591 c 7.1. ==> message si erreur
 592 c
 593       if ( codret.ne.0 ) then
 594 c
 595 #include "envex2.h"
 596 c
 597       write (ulsort,texte(langue,1)) 'Sortie', nompro
 598       write (ulsort,texte(langue,2)) codret
 599       write (ulsort,texte(langue,6)) typobs
 600 c
 601       endif
 602 c
 603 c 7.2. ==> fin des mesures de temps de la section
 604 c
 605       if ( nrosec.gt.0 ) then
 606         call gtfims (nrosec)
 607       endif
 608 c
 609 #ifdef _DEBUG_HOMARD_
 610       write (ulsort,texte(langue,1)) 'Sortie', nompro
 611       call dmflsh (iaux)
 612 #endif
 613 c
 614 c=======================================================================
 615       endif
 616 c=======================================================================
 617 c
 618       end