src/tool/ES_MED/eslsm5.F

   1       subroutine eslsm5 ( nbfonc, defonc, nofonc, nbseal,
   2      >                    nbpafo, noinpf, option,
   3      >                    ulsort, langue, codret )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c  Entree-Sortie - Lecture d'une Solution au format MED - phase 5
  25 c  -      -        -             -                  -           -
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . nbfonc . e   .   1    . nombre de fonctions                        .
  31 c . defonc . e   . nbinec*. description des fonctions en entier        .
  32 c .        .     . nbfonc . 1. type de support au sens MED             .
  33 c .        .     .        . 2. nombre de points de Gauss               .
  34 c .        .     .        . 3. nombre de valeurs                       .
  35 c .        .     .        . 4. nombre de valeurs du profil eventuel    .
  36 c .        .     .        . 5. nombre de supports associes             .
  37 c .        .     .        . 6. 1, si aux noeuds par elements           .
  38 c .        .     .        .    2, si aux points de Gauss, associe avec .
  39 c .        .     .        .       un champ aux noeuds par elements     .
  40 c .        .     .        .    3, si aux points de Gauss autonome      .
  41 c .        .     .        .    0, sinon                                .
  42 c .        .     .        . 7. nombre de tableaux de ce type           .
  43 c .        .     .        . 8. numero du tableau dans la fonction      .
  44 c .        .     .        . 9. numero de la fonction associee si champ .
  45 c .        .     .        .    aux noeuds par element ou points de Gaus.
  46 c .        .     .        . 10. numero HOMARD du champ associe         .
  47 c .        .     .        . 11. type interpolation                     .
  48 c .        .     .        .       0, si automatique                    .
  49 c .        .     .        .       1 si degre 1, 2 si degre 2,          .
  50 c .        .     .        .       3 si iso-P2                          .
  51 c .        .     .        . 21-nbinec. type des supports associes      .
  52 c . nofonc . e   .3*nbfonc. description des fonctions en caracteres    .
  53 c .        .     .        . 1. nom de l'objet profil, blanc sinon      .
  54 c .        .     .        . 2. nom de l'objet fonction                 .
  55 c .        .     .        . 3. nom de l'objet localisation des points  .
  56 c .        .     .        . de Gauss, blanc sinon                      .
  57 c . nbseal . e   .    1   . nombre de sequences a lire                 .
  58 c .        .     .        . si -1, on lit tous les champs du fichier   .
  59 c . nbpafo .   s .   1    . nombre de paquets de fonctions             .
  60 c . noinpf .   s . nbpafo . nom des objets qui contiennent la          .
  61 c .        .     .        . description de chaque paquet de fonctions  .
  62 c . option . e   .   1    . 1 : on controle que l'on a les couples (aux.
  63 c .        .     .        . noeuds par element/aux points de Gauss)    .
  64 c .        .     .        . 0 : pas de controle                        .
  65 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  66 c . langue . e   .    1   . langue des messages                        .
  67 c .        .     .        . 1 : francais, 2 : anglais                  .
  68 c . codret . es  .    1   . code de retour des modules                 .
  69 c .        .     .        . 0 : pas de probleme                        .
  70 c .        .     .        . 1 : probleme                               .
  71 c ______________________________________________________________________
  72 c
  73 c====
  74 c 0. declarations et dimensionnement
  75 c====
  76 c
  77 c 0.1. ==> generalites
  78 c
  79       implicit none
  80       save
  81 c
  82       character*6 nompro
  83       parameter ( nompro = 'ESLSM5' )
  84 c
  85 #include "nblang.h"
  86 #include "consts.h"
  87 #include "meddc0.h"
  88 c
  89 c 0.2. ==> communs
  90 c
  91 #include "envex1.h"
  92 c
  93 #include "esutil.h"
  94 #include "gmenti.h"
  95 #include "gmstri.h"
  96 c
  97 c 0.3. ==> arguments
  98 c
  99       integer nbfonc, nbpafo, nbseal
 100       integer defonc(nbinec,*)
 101       integer option
 102 c
 103       character*8 nofonc(3,nbfonc), noinpf(*)
 104 c
 105       integer ulsort, langue, codret
 106 c
 107 c 0.4. ==> variables locales
 108 c
 109       integer iaux, jaux, kaux, laux, maux, naux
 110       integer nrfonc, nrinpf, nbfopa, nrpafo
 111       integer nrofon
 112       integer typcha
 113       integer typgeo, ngauss, nbenmx, nbvapr, nbtyas
 114       integer carsup, typint, nbtafo
 115       integer advale, advalr, adobch, adprpg, adtyas
 116       integer typch2
 117       integer typge2, ngaus2, nbenm2, nbvap2, nbtya2
 118       integer carsu2, nbtaf2, typin2
 119       integer advae2, advar2, adobc2, adobp2, adtya2
 120       integer adobfo, adtyge
 121       integer adobf2, adtyg2
 122       integer typgpf, ngaupf, carspf, typipf
 123       integer tbiaux(nbinec)
 124 c
 125       character*8 nomfon, saux08
 126       character*8 obpafo
 127       character*8 tbsaux(1)
 128 c
 129       integer nbmess
 130       parameter ( nbmess = 150 )
 131       character*80 texte(nblang,nbmess)
 132 c
 133 c 0.5. ==> initialisations
 134 c
 135       tbsaux(1) = blan08
 136 c ______________________________________________________________________
 137 c
 138 c====
 139 c 1. initialisations
 140 c====
 141 c
 142 #include "impr01.h"
 143 c
 144 #ifdef _DEBUG_HOMARD_
 145       write (ulsort,texte(langue,1)) 'Entree', nompro
 146       call dmflsh (iaux)
 147 #endif
 148 c
 149 #include "esimpr.h"
 150 c
 151       texte(1,4) = '(''Creation du paquet de fonctions '',i3,'' : '',a)'
 152       texte(1,5) =
 153      > '(''Ajout de la '',i3,''-eme fonction dans le paquet '',a)'
 154       texte(1,6) = '(''Impossible de trouver la fonction.'')'
 155       texte(1,7) = '(''Impossible de trouver le paquet.'')'
 156       texte(1,8) = '(''Nombre de paquets crees :'',i8)'
 157 c
 158       texte(2,4) = '(''Creation of pack of functions # '',i3,'' : '',a)'
 159       texte(2,5) = '(''Addition of '',i3,''-th function in pack '',a)'
 160       texte(2,6) = '(''Function cannot be found.'')'
 161       texte(2,7) = '(''Pack cannot be found.'')'
 162       texte(2,8) = '(''Number of created packs :'',i8)'
 163 c
 164 #include "impr03.h"
 165 c
 166       nbpafo = 0
 167 c
 168 c====
 169 c 2. regroupement des fonctions en paquets
 170 c====
 171 c
 172       do 20 , nrfonc = 1 , nbfonc
 173 c
 174 c 2.1. ==> caracteristiques de la fonction a ranger
 175 c
 176         if ( codret.eq.0 ) then
 177 c
 178 #ifdef _DEBUG_HOMARD_
 179         write (ulsort,texte(langue,36)) nompro, nrfonc
 180         call gmprsx (nompro, nofonc(2,nrfonc) )
 181 cgn        call gmprsx (nompro, nofonc(2,nrfonc)//'.InfoCham' )
 182 #endif
 183 #ifdef _DEBUG_HOMARD_
 184       write (ulsort,texte(langue,3)) 'utcafo', nompro
 185 #endif
 186         call utcafo ( nofonc(2,nrfonc),
 187      >                typcha,
 188      >                typgeo, ngauss, nbenmx, nbvapr, nbtyas,
 189      >                carsup, nbtafo, typint,
 190      >                advale, advalr, adobch, adprpg, adtyas,
 191      >                ulsort, langue, codret )
 192 #ifdef _DEBUG_HOMARD_
 193         write (ulsort,90002) 'Fonction numero ', nrfonc
 194         write (ulsort,90002) 'typgeo', typgeo
 195         write (ulsort,90002) 'ngauss', ngauss
 196         write (ulsort,90002) 'nbenmx', nbenmx
 197         write (ulsort,90002) 'nbvapr', nbvapr
 198         write (ulsort,90002) 'nbtyas', nbtyas
 199         write (ulsort,90002) 'carsup', carsup
 200         write (ulsort,90002) 'typint', typint
 201         write (ulsort,90002) 'nbtafo', nbtafo
 202         write (ulsort,90003) 'champ ', smem(adobch)
 203         write (ulsort,*) 'Profil   ', smem(adprpg)
 204         write (ulsort,*) 'Loca PG  ', smem(adprpg+1)
 205         write (ulsort,*) 'Fonc. As.', smem(adprpg+2)
 206 #endif
 207 c
 208         endif
 209 c
 210 c 2.2. ==> on recherche s'il existe un paquet convenable
 211 c
 212         nrinpf = 0
 213 c
 214         do 22 , iaux = 1 , nbpafo
 215 c
 216 #ifdef _DEBUG_HOMARD_
 217         write (ulsort,90002) '. Examen du paquet numero', iaux
 218 #endif
 219 c
 220 c 2.2.1. ==> caracteristiques de l'iaux-eme paquet de fonction
 221 c
 222           if ( codret.eq.0 ) then
 223 c
 224           obpafo = noinpf(iaux)
 225 c
 226 #ifdef _DEBUG_HOMARD_
 227           call gmprsx (nompro, obpafo )
 228 #endif
 229 c
 230 #ifdef _DEBUG_HOMARD_
 231       write (ulsort,texte(langue,3)) 'UTCAPF', nompro
 232 #endif
 233           call utcapf ( obpafo,
 234      >                  nbfopa, typgpf, ngaupf, carspf, typipf,
 235      >                  adobfo, adtyge,
 236      >                  ulsort, langue, codret )
 237 cgn        write (ulsort,90002) 'kaux/tnpass', kaux
 238 cgn        write (ulsort,90002) 'laux/ngauss', laux
 239 cgn        write (ulsort,90002) 'maux/carsup', maux
 240 cgn        write (ulsort,90002) 'naux/typint', naux
 241 c
 242           endif
 243 c
 244 c 2.2.2. ==> le paquet convient si le support geometrique est
 245 c            simple, tout est identique
 246 c
 247           if ( typgpf.gt.0 ) then
 248 c
 249             if ( typgeo.eq.typgpf .and.
 250      >           ngauss.eq.ngaupf .and.
 251      >           carsup.eq.carspf .and.
 252      >           typint.eq.typipf ) then
 253               nrinpf = iaux
 254               goto 23
 255             endif
 256 c
 257 c 2.2.3. ==>  ou ... si le support est multiple, le champ est le meme
 258 c
 259           elseif ( typgpf.lt.0 ) then
 260 c
 261               do 223 , jaux = 1 , nbfopa
 262 c
 263                 if ( codret.eq.0 ) then
 264 c
 265 #ifdef _DEBUG_HOMARD_
 266       write (ulsort,texte(langue,3)) 'utcafo', nompro
 267 #endif
 268 c
 269                 call utcafo ( smem(adobfo+jaux-1),
 270      >                        typch2,
 271      >                        typge2, ngaus2, nbenm2, nbvap2, nbtya2,
 272      >                        carsu2, nbtaf2, typin2,
 273      >                        advae2, advar2, adobc2, adobp2, adtya2,
 274      >                        ulsort, langue, codret )
 275 c
 276                 endif
 277 c
 278                 if ( codret.eq.0 ) then
 279 c
 280                 if ( smem(adobch).eq.smem(adobc2) ) then
 281                   nrinpf = iaux
 282                   goto 23
 283                 endif
 284 c
 285                 endif
 286 c
 287   223         continue
 288 c
 289             endif
 290 c
 291    22   continue
 292 c
 293 c 2.3. ==> creation d'un nouveau paquet
 294 c
 295    23   continue
 296 c
 297         if ( nrinpf.eq.0 ) then
 298 c
 299           if ( codret.eq.0 ) then
 300 c
 301           nbfopa = 0
 302           if ( nbtyas.le.0 ) then
 303             typgpf = typgeo
 304           else
 305             typgpf = -(nbtyas+1)
 306           endif
 307 c
 308 #ifdef _DEBUG_HOMARD_
 309       write (ulsort,texte(langue,3)) 'UTALPF', nompro
 310 #endif
 311           call utalpf ( obpafo,
 312      >                  nbfopa, typgpf, ngauss, carsup, typint,
 313      >                  adobfo, adtyge,
 314      >                  ulsort, langue, codret )
 315 c
 316           endif
 317 #ifdef _DEBUG_HOMARD_
 318           call gmprsx ( nompro//' - apres UTALPF', obpafo )
 319 #endif
 320 c
 321           if ( codret.eq.0 ) then
 322 c
 323           nbpafo = nbpafo + 1
 324           noinpf(nbpafo) = obpafo
 325 c
 326 #ifdef _DEBUG_HOMARD_
 327           write (ulsort,texte(langue,4)) nbpafo, obpafo
 328 #endif
 329 c
 330           endif
 331 c
 332           if ( nbtyas.gt.0 ) then
 333 c
 334             if ( codret.eq.0 ) then
 335 c
 336             do 231 ,iaux = 1 , nbtyas
 337               tbiaux(iaux) = imem(adtyas+iaux-1)
 338   231       continue
 339             tbiaux(nbtyas+1) = typgeo
 340 c
 341 #ifdef _DEBUG_HOMARD_
 342       write (ulsort,texte(langue,3)) 'UTMOPF', nompro
 343 #endif
 344 c
 345             iaux = nbtyas+1
 346             jaux = 5
 347             call utmopf ( obpafo, jaux,
 348      >                    iaux, tbsaux, tbiaux,
 349      >                    nofonc(2,nrfonc),
 350      >                    nbfopa, kaux, laux, maux, naux,
 351      >                    adobfo,
 352      >                    ulsort, langue, codret )
 353 c
 354 #ifdef _DEBUG_HOMARD_
 355             call gmprsx (nompro, obpafo//'.TypeSuAs' )
 356 #endif
 357 c
 358             endif
 359 c
 360           endif
 361 c
 362         endif
 363 c
 364 c 2.4. ==> ajout de la fonction dans le paquet
 365 c
 366         if ( codret.eq.0 ) then
 367 c
 368 #ifdef _DEBUG_HOMARD_
 369       write (ulsort,texte(langue,3)) 'UTMOPF', nompro
 370 #endif
 371 c
 372         jaux = 1
 373         call utmopf ( obpafo, jaux,
 374      >                nbpafo, tbsaux, tbiaux,
 375      >                nofonc(2,nrfonc),
 376      >                nbfopa, kaux, laux, maux, naux,
 377      >                adobfo,
 378      >                ulsort, langue, codret )
 379 c
 380 #ifdef _DEBUG_HOMARD_
 381         write (ulsort,texte(langue,5)) nbfopa, obpafo
 382         call gmprsx (nompro, obpafo )
 383         call gmprsx (nompro, obpafo//'.Fonction' )
 384 #endif
 385 c
 386         endif
 387 c
 388    20 continue
 389 c
 390 #ifdef _DEBUG_HOMARD_
 391       if ( codret.eq.0 ) then
 392       write (ulsort,texte(langue,8)) nbpafo
 393       write (ulsort,93010) (noinpf(nrpafo),nrpafo = 1 , nbpafo)
 394       endif
 395 #endif
 396 c
 397 c====
 398 c 3. gestion des couples (aux noeuds par element/aux points de Gauss)
 399 c====
 400 #ifdef _DEBUG_HOMARD_
 401       write (ulsort,90002) '3. gestion des couples, codret',codret
 402 #endif
 403 c
 404       if ( option.eq.1 ) then
 405 c
 406       do 30 , nrpafo = 1 , nbpafo
 407 c
 408 c 3.1. ==> caracteristiques du paquet
 409 c
 410 #ifdef _DEBUG_HOMARD_
 411         write (ulsort,90002) 'Paquet numero', nrpafo
 412 #endif
 413 c
 414         if ( codret.eq.0 ) then
 415 c
 416         obpafo = noinpf(nrpafo)
 417 c
 418 #ifdef _DEBUG_HOMARD_
 419         call gmprsx (nompro, obpafo )
 420 #endif
 421 c
 422 #ifdef _DEBUG_HOMARD_
 423       write (ulsort,texte(langue,3)) 'UTCAPF', nompro
 424 #endif
 425 c
 426         call utcapf ( obpafo,
 427      >                nbfopa, nbtyas, ngauss, carsup, typint,
 428      >                adobfo, adtyge,
 429      >                ulsort, langue, codret )
 430 #ifdef _DEBUG_HOMARD_
 431         write (ulsort,texte(langue,65+carsup))
 432         write (ulsort,90002) 'nbfopa', nbfopa
 433         write (ulsort,90002) 'nbtyas', nbtyas
 434         write (ulsort,90002) 'ngauss', ngauss
 435         write (ulsort,90002) 'carsup', carsup
 436         write (ulsort,90002) 'typint', typint
 437         write (ulsort,93010) (smem(adobfo+iaux),' ',iaux=0,nbfopa)
 438 #endif
 439 c
 440         endif
 441 c
 442 c 3.2. ==> on poursuit si c'est un paquet aux noeuds par element ou
 443 c          aux points de Gauss
 444 c
 445         if ( carsup.ge.1 .and. carsup.le.2 ) then
 446 c
 447 c 3.2.1. ==> Recherche du numero global de la premiere des fonctions
 448 c            du paquet
 449 c
 450           if ( codret.eq.0 ) then
 451 c
 452           nomfon = smem(adobfo)
 453           do 321 , iaux = 1 , nbfonc
 454             if ( nofonc(2,iaux).eq.nomfon ) then
 455               nrofon = iaux
 456               goto 3210
 457             endif
 458   321     continue
 459           codret = 4
 460           write (ulsort,texte(langue,6))
 461 c
 462  3210     continue
 463 c
 464           endif
 465 c
 466 c 3.2.2. ==> Numero global et nom de la fonction associee
 467 c
 468           if ( codret.eq.0 ) then
 469 c
 470           iaux = defonc(9,nrofon)
 471           saux08 = nofonc(2,iaux)
 472 c
 473           endif
 474 c
 475 c 3.2.3. ==> Recherche du paquet contenant cette fonction associee
 476 c            Rearque : inutile de chercher dans le paquet courant ...
 477 c
 478           if ( codret.eq.0 ) then
 479 c
 480           do 323 , iaux = 1 , nbpafo
 481 c
 482             if ( iaux.ne.nrpafo ) then
 483 c
 484               if ( codret.eq.0 ) then
 485 c
 486               obpafo = noinpf(iaux)
 487 c
 488 #ifdef _DEBUG_HOMARD_
 489       write (ulsort,texte(langue,3)) 'UTCAPF', nompro
 490 #endif
 491               call utcapf ( obpafo,
 492      >                      jaux, kaux, laux, maux, naux,
 493      >                      adobf2, adtyg2,
 494      >                      ulsort, langue, codret )
 495 c
 496               endif
 497 c
 498               if ( codret.eq.0 ) then
 499 c
 500               do 3231 , nrofon = 1 , jaux
 501                 if ( smem(adobf2+nrofon-1).eq.saux08 ) then
 502                   smem(adobfo+nbfopa) = obpafo
 503                   goto 3230
 504                 endif
 505  3231         continue
 506 c
 507               endif
 508 c
 509             endif
 510 c
 511   323     continue
 512 c
 513           if ( nbseal.gt.0 .and. carsup.eq.2 ) then
 514             write (ulsort,texte(langue,7))
 515             codret = 5
 516           endif
 517 c
 518  3230     continue
 519 c
 520           endif
 521 c
 522         endif
 523 c
 524    30 continue
 525 c
 526       endif
 527 c
 528 c====
 529 c 4. la fin
 530 c====
 531 c
 532       if ( codret.ne.0 ) then
 533 c
 534 #include "envex2.h"
 535 c
 536       write (ulsort,texte(langue,1)) 'Sortie', nompro
 537       write (ulsort,texte(langue,2)) codret
 538 c
 539       endif
 540 c
 541 #ifdef _DEBUG_HOMARD_
 542       write (ulsort,texte(langue,1)) 'Sortie', nompro
 543       call dmflsh (iaux)
 544 #endif
 545 c
 546       end
 547