src/tool/ES_HOMARD/esecen.F

   1       subroutine esecen ( idfmed, nomamd,
   2      >                    nhmapo, nharet, nhtria, nhquad,
   3      >                    nhtetr, nhhexa, nhpyra, nhpent,
   4      >                     numdt,  numit, instan,
   5      >                    ltbiau, tbiaux,
   6      >                    ulsort, langue, codret)
   7 c
   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 : ECriture des ENtites
  29 c  -      -        --           --
  30 c ______________________________________________________________________
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . idfmed . e   .   1    . identificateur du fichier MED              .
  34 c . nomamd . e   . char64 . nom du maillage MED voulu                  .
  35 c . ltbiau . e   .    1   . longueur allouee a tbiaux                  .
  36 c . tbiaux .     .    *   . tableau tampon entier                      .
  37 c . numdt  . e   .   1    . numero du pas de temps                     .
  38 c . numit  . e   .   1    . numero d'iteration                         .
  39 c . instan . e   .   1    . pas de temps                               .
  40 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  41 c . langue . e   .    1   . langue des messages                        .
  42 c .        .     .        . 1 : francais, 2 : anglais                  .
  43 c . codret . es  .    1   . code de retour des modules                 .
  44 c .        .     .        . 0 : pas de probleme                        .
  45 c ______________________________________________________________________
  46 c
  47 c====
  48 c 0. declarations et dimensionnement
  49 c====
  50 c
  51 c 0.1. ==> generalites
  52 c
  53       implicit none
  54       save
  55 c
  56       character*6 nompro
  57       parameter ( nompro = 'ESECEN' )
  58 c
  59 #include "nblang.h"
  60 #include "consts.h"
  61 c
  62 c 0.2. ==> communs
  63 c
  64 #include "envex1.h"
  65 #include "gmenti.h"
  66 c
  67 #include "envca1.h"
  68 #include "nbfami.h"
  69 #include "nombmp.h"
  70 #include "nombar.h"
  71 #include "nombtr.h"
  72 #include "nombqu.h"
  73 #include "nombte.h"
  74 #include "nombpy.h"
  75 #include "nombhe.h"
  76 #include "nombpe.h"
  77 c
  78 #include "impr02.h"
  79 c
  80 c 0.3. ==> arguments
  81 c
  82       integer*8 idfmed
  83       integer numdt, numit
  84       integer ltbiau, tbiaux(*)
  85 c
  86       character*8 nhmapo, nharet, nhtria, nhquad
  87       character*8 nhtetr, nhhexa, nhpyra, nhpent
  88       character*64 nomamd
  89 c
  90       double precision instan
  91 c
  92       integer ulsort, langue, codret
  93 c
  94 c 0.4. ==> variables locales
  95 c
  96 #include "meddc0.h"
  97 c
  98       integer iaux, jaux
  99       integer typenh, typgeo, typent
 100       integer nbenti, nbencf, nbenca, nbnfma, numfam
 101       integer adcode, adcoar, adhist
 102       integer adnivo, admere, adfill
 103       integer adenho
 104       integer adinsu, lginsu
 105       integer adins2, lgins2
 106       integer adnoim
 107       integer addera, adinfg
 108       integer adfami, adcofa
 109       integer psomar
 110 c
 111       character*8 nhenti
 112 c
 113       integer nbmess
 114       parameter ( nbmess = 150 )
 115       character*80 texte(nblang,nbmess)
 116 c ______________________________________________________________________
 117 c
 118 c====
 119 c 1. messages
 120 c====
 121 c
 122 #include "impr01.h"
 123 c
 124 #ifdef _DEBUG_HOMARD_
 125       write (ulsort,texte(langue,1)) 'Entree', nompro
 126       call dmflsh (iaux)
 127 #endif
 128 c
 129       texte(1,4) = '(''. Ecriture des mailles.'')'
 130       texte(1,5) = '(/,''... '',a)'
 131 c
 132       texte(2,4) = '(''. Writings of meshes.'')'
 133       texte(2,4) = '(/,''... '',a)'
 134 c
 135 #include "impr03.h"
 136 c
 137 #include "esimpr.h"
 138 c
 139 #ifdef _DEBUG_HOMARD_
 140       write (ulsort,texte(langue,4))
 141 #endif
 142 c
 143 c====
 144 c 2. Ecriture type par type
 145 c====
 146 c
 147       do 21 , typenh = 0 , 7
 148 c
 149 c 2.1. ==> decodage des caracteristiques
 150 c
 151         if ( codret.eq.0 ) then
 152 c
 153         nbenca = 0
 154 c
 155         if ( typenh.eq.0 ) then
 156           nbenti = nbmpto
 157           nhenti = nhmapo
 158           nbencf = nbenti
 159           typgeo = edpoi1
 160           typent = edmail
 161           numfam = 0
 162           nbnfma = 1
 163         elseif ( typenh.eq.1 ) then
 164           nbenti = nbarto
 165           nbencf = nbenti
 166           nhenti = nharet
 167           if ( degre.eq.1 ) then
 168             typgeo = edseg2
 169             nbnfma = 2
 170           else
 171             typgeo = edseg3
 172             nbnfma = 3
 173           endif
 174           typent = edaret
 175           numfam = numfam - nbfmpo
 176         elseif ( typenh.eq.2 ) then
 177           nbenti = nbtrto
 178           nbencf = nbenti
 179           nhenti = nhtria
 180            if ( degre.eq.1 ) then
 181             typgeo = edtri3
 182           else
 183             typgeo = edtri6
 184           endif
 185           typent = edface
 186           numfam = numfam - nbfare
 187           nbnfma = 3
 188        elseif ( typenh.eq.3 ) then
 189           nbenti = nbteto
 190           nbencf = nbtecf
 191           nbenca = nbteca
 192           nhenti = nhtetr
 193           if ( degre.eq.1 ) then
 194             typgeo = edtet4
 195           else
 196             typgeo = edte10
 197           endif
 198           typent = edmail
 199           numfam = numfam - nbftri
 200           nbnfma = 4
 201         elseif ( typenh.eq.4 ) then
 202           nbenti = nbquto
 203           nbencf = nbenti
 204           nhenti = nhquad
 205           if ( degre.eq.1 ) then
 206             typgeo = edqua4
 207           else
 208             typgeo = edqua8
 209           endif
 210           typent = edface
 211           numfam = numfam - nbftet
 212           nbnfma = 4
 213         elseif ( typenh.eq.5 ) then
 214           nbenti = nbpyto
 215           nbencf = nbpycf
 216           nbenca = nbpyca
 217           nhenti = nhpyra
 218           if ( degre.eq.1 ) then
 219             typgeo = edpyr5
 220           else
 221             typgeo = edpy13
 222           endif
 223           typent = edmail
 224           numfam = numfam - nbfqua
 225           nbnfma = 5
 226         elseif ( typenh.eq.6 ) then
 227           nbenti = nbheto
 228           nbencf = nbhecf
 229           nbenca = nbheca
 230           nhenti = nhhexa
 231           if ( degre.eq.1 ) then
 232             typgeo = edhex8
 233           else
 234             typgeo = edhe20
 235           endif
 236           typent = edmail
 237           numfam = numfam - nbfpyr
 238           nbnfma = 6
 239         else
 240           nbenti = nbpeto
 241           nbencf = nbpecf
 242           nbenca = nbpeca
 243           nhenti = nhpent
 244           if ( degre.eq.1 ) then
 245             typgeo = edpen6
 246           else
 247             typgeo = edpe15
 248           endif
 249           typent = edmail
 250           numfam = numfam - nbfhex
 251           nbnfma = 5
 252         endif
 253 c
 254         endif
 255 c
 256 c 2.2. ==> Determination de toutes les adresses possibles
 257 c
 258         if ( codret.eq.0 ) then
 259 c
 260 #ifdef _DEBUG_HOMARD_
 261         write (ulsort,texte(langue,5)) mess14(langue,4,typenh)
 262         write (ulsort,90002) 'nbenti, nbencf, nbenca',
 263      >                        nbenti, nbencf, nbenca
 264         write (ulsort,90002) 'typgeo', typgeo
 265         write (ulsort,90002) 'nbnfma', nbnfma
 266 #endif
 267 c
 268         if ( nbenti.gt.0 ) then
 269 c
 270 #ifdef _DEBUG_HOMARD_
 271       write (ulsort,texte(langue,3)) 'UTAD22', nompro
 272 #endif
 273           call utad22 ( nhenti,
 274      >                  adcode, adcoar, adhist,
 275      >                  adnivo, admere, adfill,
 276      >                  adenho,
 277      >                  adinsu, lginsu,
 278      >                  adins2, lgins2,
 279      >                  adnoim,
 280      >                  addera, adinfg,
 281      >                  adfami, adcofa,
 282      >                  ulsort, langue, codret )
 283 c
 284         endif
 285 c
 286         endif
 287 c
 288         if ( codret.eq.0 ) then
 289 c
 290         if ( typenh.eq.1 ) then
 291           psomar = adcode
 292         endif
 293 c
 294         endif
 295 c
 296 c 2.3. ==> ecriture des connectivites
 297 c
 298         if ( codret.eq.0 ) then
 299 c
 300         if ( nbenti.gt.0 ) then
 301 c
 302           jaux = typenh
 303 #ifdef _DEBUG_HOMARD_
 304         write (ulsort,texte(langue,3)) 'ESECE0', nompro
 305 #endif
 306           call esece0 ( idfmed, nomamd,
 307      >                  jaux, typgeo, typent,
 308      >                  nbenti, nbencf, nbenca, nbnfma,
 309      >                  imem(psomar),
 310      >                  imem(adcode), imem(adinsu), imem(adcoar),
 311      >                  numdt, numit, instan,
 312      >                  ltbiau, tbiaux,
 313      >                  ulsort, langue, codret )
 314 c
 315         endif
 316 c
 317         endif
 318 cgn        call gmprsx(nompro,nhenti//'.HistEtat')
 319 cgn        call gmprsx(nompro,nhenti//'.Niveau  ')
 320 cgn        call gmprsx(nompro,nhenti//'.InfoSupp')
 321 c
 322 c 2.3. ==> ecriture des complements
 323 c
 324         if ( codret.eq.0 ) then
 325 c
 326         if ( nbenti.gt.0 ) then
 327 c
 328           jaux = typenh
 329 #ifdef _DEBUG_HOMARD_
 330         write (ulsort,texte(langue,3)) 'ESECE1', nompro
 331 #endif
 332           call esece1 ( idfmed, nomamd,
 333      >                  jaux, typgeo, typent,
 334      >                  nbenti, nbencf, nbenca,
 335      >                  adfami, adhist,
 336      >                  adnivo, admere,
 337      >                  adenho,
 338      >                  adinsu, lginsu,
 339      >                  adins2, lgins2,
 340      >                  adnoim,
 341      >                  addera,
 342      >                  numdt, numit, instan,
 343      >                  ltbiau, tbiaux,
 344      >                  ulsort, langue, codret )
 345 c
 346         endif
 347 c
 348         endif
 349 c
 350    21 continue
 351 c
 352 c====
 353 c 3. la fin
 354 c====
 355 c
 356       if ( codret.ne.0 ) then
 357 c
 358 #include "envex2.h"
 359 c
 360       write (ulsort,texte(langue,1)) 'Sortie', nompro
 361       write (ulsort,texte(langue,2)) codret
 362 c
 363       endif
 364 c
 365 #ifdef _DEBUG_HOMARD_
 366       write (ulsort,texte(langue,1)) 'Sortie', nompro
 367       call dmflsh (iaux)
 368 #endif
 369 c
 370       end