src/tool/ES_HOMARD/esecfd.F

   1       subroutine esecfd ( idfmed,
   2      >                    nocdfr,
   3      >                    ltbiau, tbiaux, ltbsau, tbsaux,
   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 : ECriture des Frontieres Discretes
  27 c  -      -        --           -          -
  28 c ______________________________________________________________________
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . idfmed . e   .   1    . identificateur du fichier MED              .
  32 c . nocdfr . e   . char8  . nom de l'objet description de la frontiere .
  33 c . ltbiau . e   .    1   . longueur allouee a tbiaux                  .
  34 c . tbiaux .     .    *   . tableau tampon entier                      .
  35 c . ltbsau . e   .    1   . longueur allouee a tbsaux                  .
  36 c . tbsaux .     .    *   . tableau tampon caracteres                  .
  37 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  38 c . langue . e   .    1   . langue des messages                        .
  39 c .        .     .        . 1 : francais, 2 : anglais                  .
  40 c . codret . es  .    1   . code de retour des modules                 .
  41 c .        .     .        . 0 : pas de probleme                        .
  42 c ______________________________________________________________________
  43 c
  44 c====
  45 c 0. declarations et dimensionnement
  46 c====
  47 c
  48 c 0.1. ==> generalites
  49 c
  50       implicit none
  51       save
  52 c
  53       character*6 nompro
  54       parameter ( nompro = 'ESECFD' )
  55 c
  56 #include "nblang.h"
  57 #include "consts.h"
  58 c
  59 c 0.2. ==> communs
  60 c
  61 #include "motcle.h"
  62 #include "gmenti.h"
  63 #include "gmreel.h"
  64 #include "gmstri.h"
  65 #include "envex1.h"
  66 c
  67 c 0.3. ==> arguments
  68 c
  69       integer*8 idfmed
  70       integer ltbiau, tbiaux(ltbiau)
  71       integer ltbsau
  72 c
  73       character*8 nocdfr
  74       character*8 tbsaux(ltbsau)
  75 c
  76       integer ulsort, langue, codret
  77 c
  78 c 0.4. ==> variables locales
  79 c
  80 #include "meddc0.h"
  81 c
  82       integer iaux, jaux
  83       integer lnomaf
  84       integer adabsc, psomse, psegli, pnumli, ptypli, pgeoco
  85       integer lgpttg, lgtabl
  86       integer pttgrl, ptngrl, pointl
  87       integer sfsdim, sfmdim, sfnbso, sfnbli, sfnbse
  88       integer ngro
  89 c
  90       character*8 typobs
  91       character*64 saux64
  92       character*64 nomamd
  93       character*64 nomafr
  94       character*64 noprof
  95       character*200 sau200
  96 c
  97       integer codre0
  98       integer codre1, codre2, codre3, codre4, codre5
  99       integer codre6
 100 c
 101       integer nbmess
 102       parameter ( nbmess = 150 )
 103       character*80 texte(nblang,nbmess)
 104 c ______________________________________________________________________
 105 c
 106 c====
 107 c 1. initialisation
 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) = '(''. Ecriture des frontieres discretes.'')'
 118       texte(1,5) = '(5x,''Ecriture de la frontiere discrete '',a)'
 119 c
 120       texte(2,4) = '(''. Writings of discrete boundaries.'')'
 121       texte(2,5) = '(5x,''Writing of the discrete boundary '',a)'
 122 c
 123 #include "impr03.h"
 124 c
 125 #include "esimpr.h"
 126 c
 127 #ifdef _DEBUG_HOMARD_
 128       write (ulsort,texte(langue,4))
 129 #endif
 130 c
 131       codret = 0
 132 c
 133 cgn      call gmprsx (nompro, nocdfr )
 134 cgn      call gmprsx (nompro, nocdfr//'.CoorNoeu' )
 135 cgn      call gmprsx (nompro, nocdfr//'.NumeLign' )
 136 cgn      call gmprsx (nompro, nocdfr//'.PtrSomLi' )
 137 cgn      call gmprsx (nompro, nocdfr//'.SommSegm' )
 138 cgn      call gmprsx (nompro, nocdfr//'.AbsCurvi' )
 139 cgn      call gmprsx (nompro, nocdfr//'.Groupes' )
 140 c
 141 c====
 142 c 2. Caracteristique de la frontiere
 143 c====
 144 #ifdef _DEBUG_HOMARD_
 145       write (ulsort,90002) '2. nom de la frontiere ; codret', codret
 146 #endif
 147 c
 148 c 2.1. ==> Recuperation du nom du maillage de la frontiere
 149 c
 150       typobs = mccnmf
 151       iaux = 0
 152       jaux = 0
 153       call utfino ( typobs, iaux, nomafr, lnomaf,
 154      >              jaux,
 155      >              ulsort, langue, codret )
 156 c
 157       if ( codret.eq.0 ) then
 158 c
 159       write (ulsort,texte(langue,5)) nomafr(1:lnomaf)
 160 c
 161       endif
 162 c
 163 c 2.2. ==> Adresses
 164 c
 165       if ( codret.eq.0 ) then
 166 c
 167       call gmliat ( nocdfr, 1, sfsdim, codre1 )
 168       call gmliat ( nocdfr, 2, sfmdim, codre2 )
 169       call gmliat ( nocdfr, 3, sfnbso, codre3 )
 170       call gmliat ( nocdfr, 4, sfnbli, codre4 )
 171       call gmliat ( nocdfr, 5, sfnbse, codre5 )
 172 c
 173       codre0 = min ( codre1, codre2, codre3, codre4, codre5 )
 174       codret = max ( abs(codre0), codret,
 175      >               codre1, codre2, codre3, codre4, codre5 )
 176 c
 177       endif
 178 c
 179 #ifdef _DEBUG_HOMARD_
 180       write (ulsort,90002) 'sfsdim', sfsdim
 181       write (ulsort,90002) 'sfmdim', sfmdim
 182       write (ulsort,90002) 'sfnbso', sfnbso
 183       write (ulsort,90002) 'sfnbli', sfnbli
 184       write (ulsort,90002) 'sfnbse', sfnbse
 185 #endif
 186 c
 187       if ( codret.eq.0 ) then
 188 c
 189       call gmadoj ( nocdfr//'.CoorNoeu', pgeoco, iaux, codre1 )
 190       call gmadoj ( nocdfr//'.NumeLign', pnumli, iaux, codre2 )
 191       call gmadoj ( nocdfr//'.TypeLign', ptypli, iaux, codre3 )
 192       call gmadoj ( nocdfr//'.PtrSomLi', psegli, iaux, codre4 )
 193       call gmadoj ( nocdfr//'.SommSegm', psomse, iaux, codre5 )
 194       call gmadoj ( nocdfr//'.AbsCurvi', adabsc, iaux, codre6 )
 195 c
 196       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 197      >               codre6 )
 198       codret = max ( abs(codre0), codret,
 199      >               codre1, codre2, codre3, codre4, codre5,
 200      >               codre6 )
 201 c
 202       endif
 203 c
 204       if ( codret.eq.0 ) then
 205 c
 206       iaux = 6
 207 #ifdef _DEBUG_HOMARD_
 208       write (ulsort,texte(langue,3)) 'UTADPT', nompro
 209 #endif
 210       call utadpt ( nocdfr//'.Groupes', iaux,
 211      >              lgpttg, lgtabl,
 212      >              pointl, pttgrl, ptngrl,
 213      >              ulsort, langue, codret )
 214 c
 215       endif
 216 c
 217 #ifdef _DEBUG_HOMARD_
 218       write (ulsort,90002) 'lgpttg', lgpttg
 219       write (ulsort,90002) 'lgtabl', lgtabl
 220 #endif
 221 c
 222 c====
 223 c 3. Creation d'un maillage pour les coordonnees des noeuds
 224 c====
 225 #ifdef _DEBUG_HOMARD_
 226       write (ulsort,90002) '3. coordonnees des noeuds ; codret', codret
 227 #endif
 228 c
 229 c 3.1. ==> Creation du maillage
 230 c
 231       if ( codret.eq.0 ) then
 232 #ifdef _DEBUG_HOMARD_
 233       write (ulsort,90002) '3.1. Creation maillage 1 ; codret', codret
 234 #endif
 235 c
 236 c               123456789012345678901
 237       sau200 = 'La frontiere discrete'
 238       do 31 , iaux = 1 , 40
 239         tbsaux(iaux) = blan08
 240    31 continue
 241       tbsaux( 1)      = 'NomCo   '
 242       tbsaux(10)(8:8) = '0'
 243       tbsaux(11)      = 'UniteCo '
 244       tbsaux(21)      = sau200(01:08)
 245       tbsaux(22)      = sau200(09:16)
 246       tbsaux(23)      = sau200(17:24)
 247       tbsaux(31)      = 'NOMAMD  '
 248       call utchs8 ( nomafr, lnomaf, tbsaux(32),
 249      >              ulsort, langue, codret )
 250 c
 251 #ifdef _DEBUG_HOMARD_
 252       write (ulsort,texte(langue,3)) 'ESEMM0', nompro
 253 #endif
 254       call esemm0 ( idfmed, nomafr,
 255      >              sfsdim, sfmdim, sau200,
 256      >                   4, tbsaux,
 257      >              ulsort, langue, codret)
 258 c
 259       endif
 260 c
 261 c 3.2. ==> Ecriture des coordonnees et des familles
 262 #ifdef _DEBUG_HOMARD_
 263       write (ulsort,90002) '3.2. Coordonnees ; codret', codret
 264 #endif
 265 c
 266 c 3.2.1. ==> Familles des noeuds
 267 c            Le tableau sert a stocker la description des lignes
 268 c
 269       if ( codret.eq.0 ) then
 270 c
 271       do 321 , iaux = 1 , sfnbso
 272         tbiaux(iaux) = 0
 273   321 continue
 274       tbiaux(1) = sfnbli
 275       do 322 , iaux = 0 , sfnbli-1
 276         tbiaux(iaux+2) = imem(pnumli+iaux)
 277   322 continue
 278       do 323 , iaux = 0 , sfnbli-1
 279         tbiaux(iaux+sfnbli+2) = imem(ptypli+iaux)
 280   323 continue
 281       do 324 , iaux = 0 , sfnbli
 282         tbiaux(iaux+2*sfnbli+2) = imem(psegli+iaux)
 283   324 continue
 284 cgn      write(ulsort,*) (tbiaux(iaux), iaux=1, 3*(sfnbli+1))
 285 c
 286 c 3.2.2. ==> Ecriture
 287 c
 288 #ifdef _DEBUG_HOMARD_
 289       write (ulsort,texte(langue,3)) 'ESEMNO', nompro
 290 #endif
 291       call esemno ( idfmed, nomafr,
 292      >              sfnbso, sfsdim, rmem(pgeoco), tbiaux,
 293      >              ednodt, ednoit, edundt,
 294      >              ulsort, langue, codret )
 295 c
 296       endif
 297 c
 298 c====
 299 c 4. Creation d'un maillage pour les abscisses curvilignes
 300 c====
 301 #ifdef _DEBUG_HOMARD_
 302       write (ulsort,90002) '4. Abscisses curvilignes ; codret', codret
 303 #endif
 304 c
 305 c 4.1. ==> Creation d'un pseudo-maillage
 306 c          Le nom doit etre coherent avec eslmh2
 307 c
 308       if ( codret.eq.0 ) then
 309 #ifdef _DEBUG_HOMARD_
 310       write (ulsort,90002) '4.1. Creation maillage 2 ; codret', codret
 311 #endif
 312 c
 313       nomamd = blan64
 314       nomamd(1:8) = 'AbsCurvi'
 315 c
 316       sau200 = 'Abscisses curvilignes'
 317 c               12345678901234567890123
 318       do 41 , iaux = 1 , 40
 319         tbsaux(iaux) = blan08
 320    41 continue
 321       tbsaux( 1)      = 'NomCo   '
 322       tbsaux(10)(8:8) = '0'
 323       tbsaux(11)      = 'UniteCo '
 324       tbsaux(21)      = sau200(01:08)
 325       tbsaux(22)      = sau200(09:16)
 326       tbsaux(23)      = sau200(17:24)
 327       tbsaux(31)      = 'NOMAMD  '
 328       tbsaux(32)      = nomamd(1:8)
 329 c
 330       iaux = 1
 331 #ifdef _DEBUG_HOMARD_
 332       write (ulsort,texte(langue,3)) 'ESEMM0', nompro
 333 #endif
 334       call esemm0 ( idfmed, nomamd,
 335      >                iaux,   iaux, sau200,
 336      >                   4, tbsaux,
 337      >              ulsort, langue, codret)
 338 c
 339       endif
 340 c
 341 c 4.2. ==> Ecriture des coordonnees et des familles
 342 c          La famille sert a stocker le lien sommet/segment
 343 c
 344 #ifdef _DEBUG_HOMARD_
 345       write (ulsort,90002) '4.2. Coordonnees ; codret', codret
 346 #endif
 347 c
 348       if ( codret.eq.0 ) then
 349 c
 350       iaux = 1
 351 #ifdef _DEBUG_HOMARD_
 352       write (ulsort,texte(langue,3)) 'ESEMNO', nompro
 353 #endif
 354       call esemno ( idfmed, nomamd,
 355      >              sfnbse, iaux, rmem(adabsc), imem(psomse),
 356      >              ednodt, ednoit, edundt,
 357      >              ulsort, langue, codret )
 358 c
 359       endif
 360 c
 361 c====
 362 c 5. Les groupes
 363 c====
 364 #ifdef _DEBUG_HOMARD_
 365       write (ulsort,90002) '5. Groupes ; codret', codret
 366 #endif
 367 c
 368 c 5.1. ==> Creation d'un profil pour les valeurs entieres
 369 c
 370       if ( codret.eq.0 ) then
 371 c
 372       tbiaux(1) = lgpttg
 373       tbiaux(2) = lgtabl
 374       do 511 , iaux = 0 , lgpttg
 375         tbiaux(iaux+3) = imem(pointl+iaux)
 376   511 continue
 377       jaux = lgpttg+3
 378       do 512 , iaux = 1 , lgtabl
 379         tbiaux(jaux+iaux) = imem(pttgrl+iaux-1)
 380   512 continue
 381 #ifdef _DEBUG_HOMARD_
 382       write(ulsort,*) (tbiaux(iaux),iaux=1,3+lgpttg+lgtabl)
 383 #endif
 384 c
 385       noprof = blan64
 386 c                     1234567890123456789012
 387       noprof(1:22) = 'Groupes_des_frontieres'
 388 c
 389       iaux = 3 + lgpttg + lgtabl
 390 #ifdef _DEBUG_HOMARD_
 391       write (ulsort,texte(langue,61)) noprof
 392       write (ulsort,texte(langue,62)) iaux
 393 #endif
 394 c
 395 #ifdef _DEBUG_HOMARD_
 396       write (ulsort,texte(langue,3)) 'MPFPRW', nompro
 397 #endif
 398       call mpfprw ( idfmed, noprof, iaux, tbiaux, codret )
 399 c
 400       endif
 401 c
 402 c 5.2. ==> Creation d'une famille pour les noms des groupes
 403 c
 404       if ( codret.eq.0 ) then
 405 c
 406       jaux = mod(lgtabl,10)
 407       if ( jaux.eq.0 ) then
 408         iaux = lgtabl/10
 409       else
 410         iaux = (lgtabl-jaux)/10 + 1
 411       endif
 412       ngro = iaux + 1
 413 c
 414       do 521 , iaux = 1 , lgtabl
 415         tbsaux(iaux) = smem(ptngrl+iaux-1)
 416   521 continue
 417 c
 418       do  522 , iaux = lgtabl+1 , 10*ngro
 419         tbsaux(iaux) = blan08
 420   522 continue
 421 c
 422 #ifdef _DEBUG_HOMARD_
 423       write (ulsort,90002) 'ngro', ngro
 424       do 524 , iaux = 1 , ngro
 425         write(ulsort,*) (tbsaux(10*(iaux-1)+jaux)//'+',jaux=1,10)
 426   524 continue
 427 #endif
 428 c
 429       iaux = 1
 430       saux64 = blan64
 431 c                    1234567
 432       saux64(1:7) = 'Groupes'
 433 #ifdef _DEBUG_HOMARD_
 434       write (ulsort,texte(langue,3)) 'MFACRE', nompro
 435 #endif
 436       call mfacre ( idfmed, nomafr, saux64, iaux,
 437      >              ngro, tbsaux, codret )
 438 c
 439       endif
 440 c
 441 c====
 442 c 6. la fin
 443 c====
 444 c
 445       if ( codret.ne.0 ) then
 446 c
 447 #include "envex2.h"
 448 c
 449       write (ulsort,texte(langue,1)) 'Sortie', nompro
 450       write (ulsort,texte(langue,2)) codret
 451 c
 452       endif
 453 c
 454 #ifdef _DEBUG_HOMARD_
 455       write (ulsort,texte(langue,1)) 'Sortie', nompro
 456       call dmflsh (iaux)
 457 #endif
 458 c
 459       end