src/tool/ES_HOMARD/eslmh7.F

   1       subroutine eslmh7 ( idfmed,
   2      >                    nocdfr, ncafdg,
   3      >                    ltbiau, tbiaux, ltbsau, tbsaux,
   4      >                    nomafr, lnomaf,
   5      >                    ulsort, langue, codret)
   6 c
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c  Entree-Sortie : Lecture du Maillage Homard - phase 7
  28 c  -      -        -          -        -              -
  29 c ______________________________________________________________________
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . idfmed . e   .   1    . identificateur du fichier MED              .
  33 c . nocdfr .  s  . char8  . nom de l'objet description de la frontiere .
  34 c . ncafdg .  s  . char*8 . nom de l'objet groupes frontiere           .
  35 c . ltbiau . e   .    1   . longueur allouee a tbiaux                  .
  36 c . tbiaux . e   .   *    . tableau de travail                         .
  37 c . ltbsau . e   .    1   . longueur allouee a tbsaux                  .
  38 c . tbsaux .     .    *   . tableau tampon caracteres                  .
  39 c . nomafr . e   . char64 . nom du maillage MED de la frontiere        .
  40 c . lnomaf . e   .   1    . longueur du nom du maillage de la frontiere.
  41 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  42 c . langue . e   .    1   . langue des messages                        .
  43 c .        .     .        . 1 : francais, 2 : anglais                  .
  44 c . codret . es  .    1   . code de retour des modules                 .
  45 c .        .     .        . 0 : pas de probleme                        .
  46 c ______________________________________________________________________
  47 c
  48 c====
  49 c 0. declarations et dimensionnement
  50 c====
  51 c
  52 c 0.1. ==> generalites
  53 c
  54       implicit none
  55       save
  56 c
  57       character*6 nompro
  58       parameter ( nompro = 'ESLMH7' )
  59 c
  60 #include "nblang.h"
  61 #include "consts.h"
  62 c
  63 c 0.2. ==> communs
  64 c
  65 #include "gmenti.h"
  66 #include "gmreel.h"
  67 #include "gmstri.h"
  68 c
  69 #include "front1.h"
  70 #include "envex1.h"
  71 c
  72 c 0.3. ==> arguments
  73 c
  74       integer*8 idfmed
  75       integer ltbiau, tbiaux(ltbiau)
  76       integer ltbsau
  77       integer lnomaf
  78 c
  79       character*8 tbsaux(ltbsau)
  80       character*8 nocdfr, ncafdg
  81       character*64 nomafr
  82 c
  83       integer ulsort, langue, codret
  84 c
  85 c 0.4. ==> variables locales
  86 c
  87 #include "meddc0.h"
  88 c
  89       integer iaux, jaux
  90       integer codre0
  91       integer codre1, codre2, codre3, codre4, codre5
  92 c
  93       integer pgeoco, psomse, pnumli, ptypli, psegli, adabsc
  94       integer lgpttg, lgtabl
  95       integer pttgrl, ptngrl, pointl
  96       integer ngro
  97 c
  98       character*64 noprof
  99       character*64 saux64
 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,''Recuperation de la frontiere discrete '',a)'
 118 c
 119       texte(2,4) = '(5x,''Readings of the discrete boundary '',a)'
 120 c
 121 #include "impr03.h"
 122 c
 123 #include "esimpr.h"
 124 c
 125       write (ulsort,texte(langue,4)) nomafr(1:lnomaf)
 126 c
 127       codret = 0
 128 c
 129 c====
 130 c 2. Allocation de l'objet frontiere discrete
 131 c====
 132 #ifdef _DEBUG_HOMARD_
 133       write (ulsort,90002) '2. Allocations frontiere ; codret', codret
 134 #endif
 135 #ifdef _DEBUG_HOMARD_
 136       write (ulsort,90002) 'sfsdim', sfsdim
 137       write (ulsort,90002) 'sfmdim', sfmdim
 138       write (ulsort,90002) 'sfnbso', sfnbso
 139       write (ulsort,90002) 'sfnbse', sfnbse
 140 #endif
 141 c
 142       if ( codret.eq.0 ) then
 143 c
 144       call gmalot ( nocdfr, 'Cal_Fron', 0, iaux, codre1 )
 145       call gmecat ( nocdfr, 1, sfsdim, codre2 )
 146       call gmecat ( nocdfr, 2, sfmdim, codre3 )
 147       call gmecat ( nocdfr, 3, sfnbso, codre4 )
 148       call gmecat ( nocdfr, 5, sfnbse, codre5 )
 149 c
 150       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 151       codret = max ( abs(codre0), codret,
 152      >               codre1, codre2, codre3, codre4, codre5 )
 153 c
 154       iaux = sfsdim*sfnbso
 155       call gmaloj ( nocdfr//'.CoorNoeu', ' ', iaux, pgeoco, codre1 )
 156       call gmaloj ( nocdfr//'.SommSegm', ' ', sfnbse, psomse, codre2 )
 157       call gmaloj ( nocdfr//'.AbsCurvi', ' ', sfnbse, adabsc, codre3 )
 158 c
 159       codre0 = min ( codre1, codre2, codre3 )
 160       codret = max ( abs(codre0), codret,
 161      >               codre1, codre2, codre3 )
 162 c
 163       endif
 164 c
 165 c====
 166 c 3. Lecture des coordonnes des noeuds
 167 c====
 168 #ifdef _DEBUG_HOMARD_
 169       write (ulsort,90002) '3. Lecture ; codret', codret
 170 #endif
 171 c
 172 c 3.1. ==> Lecture des coordonnees et des familles des noeuds
 173 c
 174       if ( codret.eq.0 ) then
 175 c
 176       iaux = 1
 177 #ifdef _DEBUG_HOMARD_
 178       write (ulsort,texte(langue,3)) 'ESLMNO-'//nomafr(1:lnomaf), nompro
 179 #endif
 180       call eslmno ( idfmed, nomafr,
 181      >                iaux,
 182      >              sfnbso, sfsdim, rmem(pgeoco), tbiaux,
 183      >              ulsort, langue, codret )
 184 c
 185       endif
 186 c
 187 c 3.2. ==> Description des lignes
 188 c
 189       if ( codret.eq.0 ) then
 190 c
 191       sfnbli = tbiaux(1)
 192 #ifdef _DEBUG_HOMARD_
 193       write (ulsort,90002) 'sfnbli', sfnbli
 194       write(ulsort,*) (tbiaux(iaux), iaux=1, 2*(sfnbli+1)+1)
 195 #endif
 196       call gmecat ( nocdfr, 4, sfnbli, codre1 )
 197       call gmaloj ( nocdfr//'.NumeLign', ' ', sfnbli, pnumli, codre2 )
 198       call gmaloj ( nocdfr//'.TypeLign', ' ', sfnbli, ptypli, codre3 )
 199       call gmaloj ( nocdfr//'.PtrSomLi', ' ', sfnbli+1, psegli, codre4 )
 200 c
 201       codre0 = min ( codre1, codre2, codre3, codre4 )
 202       codret = max ( abs(codre0), codret,
 203      >               codre1, codre2, codre3, codre4 )
 204 c
 205       endif
 206 c
 207       if ( codret.eq.0 ) then
 208 c
 209       do 321 , iaux = 0 , sfnbli-1
 210         imem(pnumli+iaux) = tbiaux(iaux+2)
 211   321 continue
 212       do 322 , iaux = 0 , sfnbli-1
 213         imem(ptypli+iaux) = tbiaux(iaux+sfnbli+2)
 214   322 continue
 215       do 323 , iaux = 0 , sfnbli
 216         imem(psegli+iaux) = tbiaux(iaux+2*sfnbli+2)
 217   323 continue
 218 c
 219 #ifdef _DEBUG_HOMARD_
 220       call gmprsx ( nompro, nocdfr )
 221       call gmprsx ( nompro, nocdfr//'.NumeLign' )
 222       call gmprsx ( nompro, nocdfr//'.TypeLign' )
 223       call gmprsx ( nompro, nocdfr//'.PtrSomLi' )
 224 #endif
 225 c
 226       endif
 227 c
 228 c====
 229 c 4. Lecture des abscisses curvilignes
 230 c====
 231 #ifdef _DEBUG_HOMARD_
 232       write (ulsort,90002) '4. Abscisses curvilignes ; codret', codret
 233 #endif
 234 c      Le nom doit etre coherent avec eslmh2
 235 c
 236       if ( codret.eq.0 ) then
 237 #ifdef _DEBUG_HOMARD_
 238       write (ulsort,90002) '4.1. Creation maillage 2 ; codret', codret
 239 #endif
 240 c
 241       saux64 = blan64
 242       saux64(1:8) = 'AbsCurvi'
 243 c
 244       iaux = 1
 245 #ifdef _DEBUG_HOMARD_
 246       write (ulsort,texte(langue,3)) 'ESLMNO-'//saux64(1:8), nompro
 247 #endif
 248       call eslmno ( idfmed, saux64,
 249      >                iaux,
 250      >              sfnbse, iaux, rmem(adabsc), imem(psomse),
 251      >              ulsort, langue, codret )
 252 c
 253       endif
 254 c
 255 c====
 256 c 5. Lecture des groupes
 257 c====
 258 #ifdef _DEBUG_HOMARD_
 259       write (ulsort,90002) '5. Groupes ; codret', codret
 260 #endif
 261 c
 262 c 5.1. ==> Lecture des valeurs entieres
 263 c
 264       if ( codret.eq.0 ) then
 265 c
 266       noprof = blan64
 267 c                     1234567890123456789012
 268       noprof(1:22) = 'Groupes_des_frontieres'
 269 c
 270 #ifdef _DEBUG_HOMARD_
 271       write (ulsort,texte(langue,3)) 'MPFPRR', nompro
 272 #endif
 273       call mpfprr ( idfmed, noprof, tbiaux, codret )
 274 c
 275       endif
 276 #ifdef _DEBUG_HOMARD_
 277       write (ulsort,texte(langue,61)) noprof
 278 #endif
 279 c
 280 c 5.2. ==> Memoire
 281 c
 282       if ( codret.eq.0 ) then
 283 c
 284       lgpttg = tbiaux(1)
 285       lgtabl = tbiaux(2)
 286 c
 287 #ifdef _DEBUG_HOMARD_
 288       write (ulsort,90002) 'lgpttg', lgpttg
 289       write (ulsort,90002) 'lgtabl', lgtabl
 290       write(ulsort,*) (tbiaux(iaux),iaux=1,3+lgpttg+lgtabl)
 291 #endif
 292 c
 293       iaux = 1
 294       jaux = 0
 295 c
 296 #ifdef _DEBUG_HOMARD_
 297       write (ulsort,texte(langue,3)) 'UTAPTC', nompro
 298 #endif
 299       call utaptc ( nocdfr//'.Groupes', iaux, jaux,
 300      >              lgpttg, lgtabl,
 301      >              pointl, pttgrl, ptngrl,
 302      >              ulsort, langue, codret )
 303 c
 304       endif
 305 c
 306       if ( codret.eq.0 ) then
 307 c
 308       call gmnomc ( nocdfr//'.Groupes', ncafdg, codret )
 309 c
 310       endif
 311 c
 312 c 5.3. ==> Lecture des caracteres
 313 c
 314       if ( codret.eq.0 ) then
 315 c
 316       jaux = mod(lgtabl,10)
 317       if ( jaux.eq.0 ) then
 318         iaux = lgtabl/10
 319       else
 320         iaux = (lgtabl-jaux)/10 + 1
 321       endif
 322       ngro = iaux + 1
 323 c
 324 #ifdef _DEBUG_HOMARD_
 325       write (ulsort,texte(langue,3)) 'MFAFAI', nompro
 326 #endif
 327       iaux = 2
 328       call mfafai ( idfmed, nomafr, iaux, saux64, jaux,
 329      >              tbsaux, codret )
 330 #ifdef _DEBUG_HOMARD_
 331       write (ulsort,*) '... Famille ', saux64
 332       write (ulsort,90002) 'numfam', jaux
 333       do 5353 , iaux = 1 , ngro
 334         write(ulsort,*) (tbsaux(10*(iaux-1)+jaux)//'+',jaux=1,10)
 335  5353 continue
 336 #endif
 337 c
 338       endif
 339 c
 340 c 5.4. ==> Transfert
 341 c
 342       if ( codret.eq.0 ) then
 343 c
 344       do 541 , iaux = 0 , lgpttg
 345         imem(pointl+iaux) = tbiaux(iaux+3)
 346   541 continue
 347 c
 348       jaux = lgpttg+3
 349       do 542 , iaux = 1 , lgtabl
 350         imem(pttgrl+iaux-1) = tbiaux(jaux+iaux)
 351   542 continue
 352 c
 353       do 543 , iaux = 1 , lgtabl
 354         smem(ptngrl+iaux-1) = tbsaux(iaux)
 355   543 continue
 356 c
 357       endif
 358 c
 359 #ifdef _DEBUG_HOMARD_
 360       if ( codret.eq.0 ) then
 361       call gmprsx (nompro, nocdfr )
 362       call gmprot (nompro, nocdfr//'.CoorNoeu', 1 , 20 )
 363       call gmprot (nompro, nocdfr//'.CoorNoeu', sfnbso-20 , sfnbso )
 364       call gmprsx (nompro, nocdfr//'.NumeLign' )
 365       call gmprsx (nompro, nocdfr//'.PtrSomLi' )
 366       call gmprot (nompro, nocdfr//'.SommSegm', 1 , 20 )
 367       call gmprot (nompro, nocdfr//'.SommSegm', sfnbse-20 , sfnbse )
 368       call gmprot (nompro, nocdfr//'.AbsCurvi', 1 , 20 )
 369       call gmprot (nompro, nocdfr//'.AbsCurvi', sfnbse-20 , sfnbse )
 370       call gmprsx (nompro, nocdfr//'.Groupes' )
 371       endif
 372 #endif
 373 c
 374 c====
 375 c 6. la fin
 376 c====
 377 c
 378       if ( codret.ne.0 ) then
 379 c
 380 #include "envex2.h"
 381 c
 382       write (ulsort,texte(langue,1)) 'Sortie', nompro
 383       write (ulsort,texte(langue,2)) codret
 384 c
 385       endif
 386 c
 387 #ifdef _DEBUG_HOMARD_
 388       write (ulsort,texte(langue,1)) 'Sortie', nompro
 389       call dmflsh (iaux)
 390 #endif
 391 c
 392       end