src/tool/ES_HOMARD/esece1.F

   1       subroutine esece1 ( idfmed, nomamd,
   2      >                    typenh, typgeo, typent,
   3      >                    nbenti, nbencf, nbenca,
   4      >                    adfami, adhist,
   5      >                    adnivo, admere,
   6      >                    adenho,
   7      >                    adinsu, lginsu,
   8      >                    adins2, lgins2,
   9      >                    adnoim,
  10      >                    addera,
  11      >                    numdt, numit, instan,
  12      >                    ltbiau, tbiaux,
  13      >                    ulsort, langue, codret)
  14 c
  15 c ______________________________________________________________________
  16 c
  17 c                             H O M A R D
  18 c
  19 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  20 c
  21 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  22 c aupres des huissiers de justice Simart et Lavoir a Clamart
  23 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  24 c aupres des huissiers de justice
  25 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  26 c
  27 c    HOMARD est une marque deposee d'Electricite de France
  28 c
  29 c Copyright EDF 1996
  30 c Copyright EDF 1998
  31 c Copyright EDF 2002
  32 c Copyright EDF 2020
  33 c ______________________________________________________________________
  34 c
  35 c  Entree-Sortie : ECriture d'une Entite - 1
  36 c  -      -        --             -        -
  37 c ______________________________________________________________________
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . idfmed . e   .   1    . identificateur du fichier MED              .
  41 c . nomamd . e   . char64 . nom du maillage MED voulu                  .
  42 c . typenh . e   .   1    . code des entites                           .
  43 c .        .     .        .  -1 : noeuds                               .
  44 c .        .     .        .   0 : mailles-points                       .
  45 c .        .     .        .   1 : aretes                               .
  46 c .        .     .        .   2 : triangles                            .
  47 c .        .     .        .   3 : tetraedres                           .
  48 c .        .     .        .   4 : quadrangles                          .
  49 c .        .     .        .   5 : pyramides                            .
  50 c .        .     .        .   6 : hexaedres                            .
  51 c .        .     .        .   7 : pentaedres                           .
  52 c . typgeo . e   .   1    . type geometrique au sens MED               .
  53 c . typent . e   .   1    . type d'entite au sens MED                  .
  54 c . nbenti . e   .   1    . nombre d'entites                           .
  55 c . nbencf . e   .   1    . nombre d'entites decrites par faces        .
  56 c . nbenca . e   .   1    . nombre d'entites decrites par aretes       .
  57 c . adfami . e   .   1    . famille                                    .
  58 c . adhist . e   .   1    . historique de l'etat                       .
  59 c . adnivo . e   .   1    . niveau des entites                         .
  60 c . admere . e   .   1    . mere des entites                           .
  61 c . adinsu . e   .   1    . informations supplementaires               .
  62 c . lginsu . e   .   1    . longueur des informations supplementaires  .
  63 c . adins2 . e   .   1    . informations supplementaires numero 2      .
  64 c . lgins2 . e   .   1    . longueur des informations supplementaires 2.
  65 c . adnoim .  s  .   1    . noeud interne a la maille                  .
  66 c . numdt  . e   .   1    . numero du pas de temps                     .
  67 c . numit  . e   .   1    . numero d'iteration                         .
  68 c . instan . e   .   1    . pas de temps                               .
  69 c . ltbiau . e   .    1   . longueur allouee a tbiaux                  .
  70 c . tbiaux .     .    *   . tableau tampon entier                      .
  71 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  72 c . langue . e   .    1   . langue des messages                        .
  73 c .        .     .        . 1 : francais, 2 : anglais                  .
  74 c . codret . es  .    1   . code de retour des modules                 .
  75 c .        .     .        . 0 : pas de probleme                        .
  76 c ______________________________________________________________________
  77 c
  78 c====
  79 c 0. declarations et dimensionnement
  80 c====
  81 c
  82 c 0.1. ==> generalites
  83 c
  84       implicit none
  85       save
  86 c
  87       character*6 nompro
  88       parameter ( nompro = 'ESECE1' )
  89 c
  90 #include "nblang.h"
  91 #include "consts.h"
  92 c
  93 c 0.2. ==> communs
  94 c
  95 #include "envex1.h"
  96 c
  97 #include "gmenti.h"
  98 c
  99 #include "impr02.h"
 100 #include "enti01.h"
 101 c
 102 c 0.3. ==> arguments
 103 c
 104       integer*8 idfmed
 105       integer typenh, typgeo, typent
 106       integer nbenti, nbencf, nbenca
 107       integer adfami, adhist
 108       integer adnivo, admere
 109       integer adenho
 110       integer adinsu, lginsu
 111       integer adins2, lgins2
 112       integer adnoim
 113       integer addera
 114       integer numdt, numit
 115       integer ltbiau, tbiaux(*)
 116 c
 117       character*64 nomamd
 118 c
 119       double precision instan
 120 c
 121       integer ulsort, langue, codret
 122 c
 123 c 0.4. ==> variables locales
 124 c
 125 #include "meddc0.h"
 126 c
 127       integer nbcmax
 128       parameter ( nbcmax = 20 )
 129 c
 130       integer iaux, jaux, kaux, laux
 131       integer nbinsu
 132       integer adress(nbcmax)
 133       integer typcom(nbcmax)
 134       integer nbcomp
 135 c
 136       character*16 dtunit
 137       character*16 nomcmp(nbcmax), unicmp(nbcmax)
 138       character*64 nomcha
 139       character*64 noprof
 140 c
 141       logical prem
 142 c
 143       integer nbmess
 144       parameter ( nbmess = 150 )
 145       character*80 texte(nblang,nbmess)
 146 c
 147 c 0.5. ==> initialisation
 148 c
 149       data prem / .true. /
 150 c ______________________________________________________________________
 151 c
 152 c====
 153 c 1. initialisation
 154 c====
 155 c
 156 #include "impr01.h"
 157 c
 158 #ifdef _DEBUG_HOMARD_
 159       write (ulsort,texte(langue,1)) 'Entree', nompro
 160       call dmflsh (iaux)
 161 #endif
 162 c
 163       texte(1,4) =
 164      > '(''... Ecriture des complements pour les '',i10,1x,a)'
 165 c
 166       texte(2,4) =
 167      > '(''... Writings of additional terms for the '',i10,1x,a)'
 168 c
 169 #include "impr03.h"
 170 c
 171 #ifdef _DEBUG_HOMARD_
 172       write (ulsort,texte(langue,4)) nbenti, mess14(langue,3,typenh)
 173 #endif
 174 c
 175 #include "esimpr.h"
 176 c
 177       texte(1,4) = '(/,''Creation du champ : '',a64)'
 178       texte(1,5) = '(''Type du champ : '',i2)'
 179       texte(1,6) =
 180      > '(''Numero !     Composante     !       Unite'',/,49(''-''))'
 181       texte(1,7) = '(i6,'' !  '',a16,''  !  '',a16)'
 182       texte(1,81) = '(''Longueur allouee pour tbiaux    : '',i10)'
 183       texte(1,82) = '(''Longueur necessaire pour tbiaux : '',i10)'
 184 c
 185       texte(2,4) = '(/,''Creation of field : '',a64)'
 186       texte(2,5) = '(''Type of field : '',i2)'
 187       texte(2,6) =
 188      > '(''  #    !     Component      !       Unit'',/,49(''-''))'
 189       texte(2,7) = '(i6,'' !  '',a16,''  !  '',a16)'
 190       texte(2,81) = '(''Allocated length for tbiaux    : '',i10)'
 191       texte(2,82) = '(''Used length for tbiaux : '',i10)'
 192 c
 193 c 1.2. ==> unites : non definies
 194 c
 195       if ( prem ) then
 196 c
 197         do 12 , iaux = 1 , nbcmax
 198           unicmp(iaux) = blan16
 199    12   continue
 200         prem = .false.
 201 c
 202       endif
 203 c
 204 c====
 205 c 2. Reperage des composantes en fonction de la presence des tableaux
 206 c====
 207 c
 208       if ( codret.eq.0 ) then
 209 c
 210       nbcomp = 0
 211 c
 212 c 2.1. ==> Pour economiser, si HistEtat et Niveau sont presents, on les
 213 c          rassemble dans la premiere composante
 214 c
 215       if ( adhist.ne.0 ) then
 216         nbcomp = nbcomp + 1
 217         typcom(nbcomp) = 1
 218         adress(nbcomp) = adhist
 219         nomcmp(nbcomp) = 'HistEtat        '
 220 c                         1234567890123456
 221       endif
 222 c
 223       if ( adnivo.ne.0 ) then
 224         if ( adhist.eq.0 ) then
 225           nbcomp = nbcomp + 1
 226           typcom(nbcomp) = 1
 227           adress(nbcomp) = adnivo
 228           nomcmp(nbcomp) = 'Niveau          '
 229         else
 230           typcom(nbcomp) = 0
 231           nomcmp(nbcomp) = 'HistEtatNiveau  '
 232 c                           1234567890123456
 233         endif
 234       endif
 235 c
 236 c 2.2. ==> Composantes standard
 237 c
 238       nbcomp = nbcomp + 1
 239       typcom(nbcomp) = 1
 240       adress(nbcomp) = adfami
 241       nomcmp(nbcomp) = 'Famille         '
 242 c                       1234567890123456
 243 c
 244       if ( admere.ne.0 ) then
 245         nbcomp = nbcomp + 1
 246         typcom(nbcomp) = 1
 247         adress(nbcomp) = admere
 248         nomcmp(nbcomp) = 'Mere            '
 249       endif
 250 c
 251       if ( adenho.ne.0 ) then
 252         nbcomp = nbcomp + 1
 253         typcom(nbcomp) = 1
 254         adress(nbcomp) = adenho
 255         nomcmp(nbcomp) = 'Homologu        '
 256       endif
 257 c
 258       if ( addera.ne.0 ) then
 259         nbcomp = nbcomp + 1
 260         typcom(nbcomp) = 1
 261         adress(nbcomp) = addera
 262         nomcmp(nbcomp) = 'Deraffin        '
 263       endif
 264 c
 265       if ( adnoim.ne.0 ) then
 266         nbcomp = nbcomp + 1
 267         typcom(nbcomp) = 1
 268         adress(nbcomp) = adnoim
 269         nomcmp(nbcomp) = 'NoeuInMa        '
 270       endif
 271 c
 272 c 2.3. ==> Pour economiser, on rassemble les termes de InfoSupp dans
 273 c          la derniere composante
 274 c
 275       if ( adinsu.ne.0 ) then
 276         nbcomp = nbcomp + 1
 277         typcom(nbcomp) = 0
 278         adress(nbcomp) = adinsu
 279         nomcmp(nbcomp) = 'InfoSupp        '
 280         nbinsu = lginsu/nbencf
 281 #ifdef _DEBUG_HOMARD_
 282       write (ulsort,90002) 'nbinsu', nbinsu
 283 #endif
 284       endif
 285 c
 286 #ifdef _DEBUG_HOMARD_
 287       write (ulsort,texte(langue,85)) nbcomp
 288 #endif
 289 c
 290       endif
 291 c
 292       if ( codret.eq.0 ) then
 293 c
 294       if ( nbencf*nbcomp.gt.ltbiau ) then
 295         write (ulsort,texte(langue,85)) nbcomp
 296         write (ulsort,texte(langue,81)) ltbiau
 297         write (ulsort,texte(langue,82)) nbencf*nbcomp
 298         codret = 7
 299       endif
 300 c
 301       endif
 302 c
 303 c====
 304 c 3. Ecriture sous forme de champ pour les tableaux a une valeur
 305 c    par entite
 306 c====
 307 #ifdef _DEBUG_HOMARD_
 308       write (ulsort,90002) '3. pseudo-champ ; codret', codret
 309 #endif
 310 c
 311       if ( nbcomp.gt.0 ) then
 312 c
 313 c 3.1. ==> Creation du champ
 314 c
 315       if ( codret.eq.0 ) then
 316 c
 317       nomcha = blan64
 318       nomcha(1:8) = suffix(3,typenh)
 319 c
 320 #ifdef _DEBUG_HOMARD_
 321       write (ulsort,texte(langue,4)) nomcha
 322       write (ulsort,texte(langue,5)) edint
 323       write (ulsort,texte(langue,6))
 324       do 31 , iaux = 1 , nbcomp
 325         write (ulsort,texte(langue,7)) iaux, nomcmp(iaux), unicmp(iaux)
 326    31 continue
 327 #endif
 328 c
 329       iaux = edint
 330       dtunit = blan16
 331 c
 332 #ifdef _DEBUG_HOMARD_
 333       write (ulsort,texte(langue,3)) 'MFDCRE', nompro
 334 #endif
 335       call mfdcre ( idfmed, nomcha, iaux,
 336      >              nbcomp, nomcmp, unicmp, dtunit, nomamd, codret )
 337 c
 338       endif
 339 c
 340       endif
 341 c
 342 c 3.2. ==> Le tableau des valeurs du champ, en mode non entrelace.
 343 c    En fortran, cela correspond au stockage memoire suivant :
 344 c    tbiaux(1,1), tbiaux(2,1), tbiaux(3,1), ..., tbiaux(nbenti,1),
 345 c    tbiaux(1,2), tbiaux(2,2), tbiaux(3,2), ..., tbiaux(nbenti,2),
 346 c    ...
 347 c    tbiaux(1,nbcomp), tbiaux(2,nbcomp), ..., tbiaux(nbenti,nbcomp)
 348 c    on a ainsi toutes les valeurs pour la premiere composante, puis
 349 c    toutes les valeurs pour la seconde composante, etc.
 350 c
 351 #ifdef _DEBUG_HOMARD_
 352       write (ulsort,90002) '3.2. tableau ; codret', codret
 353 #endif
 354 c
 355       if ( codret.eq.0 ) then
 356 c
 357 c 3.2.1. ==> Les composantes standard
 358 c
 359       do 321 , iaux = 1 , nbcomp
 360 c
 361         if ( typcom(iaux).ne.0 ) then
 362 c
 363           kaux = nbenti*(iaux-1)
 364           laux = adress(iaux)-1
 365           do 3211 , jaux = 1 , nbenti
 366             tbiaux(kaux+jaux) = imem(laux+jaux)
 367  3211     continue
 368 c
 369         endif
 370 c
 371   321 continue
 372 c
 373 c 3.2.2. ==> Historique et niveau dans la premiere composante
 374 c            L'historique est un nombre entre 0 et 999, donc il faut
 375 c            decaler de 6 chiffres
 376 c
 377       if ( typcom(1).eq.0 ) then
 378 c
 379         kaux = adhist - 1
 380         laux = adnivo - 1
 381         do 322 , jaux = 1 , nbenti
 382           tbiaux(jaux) = imem(kaux+jaux) + 1000000*imem(laux+jaux)
 383   322   continue
 384 c
 385       endif
 386 c
 387       endif
 388 c
 389 c 3.2.3. ==> Informations Supplementaires dans la derniere composante
 390 c            On sait que ce sont des valeurs entre 1 et 8, donc < 10
 391 c
 392 #ifdef _DEBUG_HOMARD_
 393       write (ulsort,90002) '3.2.3. adinsu', adinsu
 394 #endif
 395 c
 396       if ( adinsu.ne.0 ) then
 397 c
 398 c 3.2.3.1. ==> Premiere valeur pour initialiser le tableau
 399 c
 400         kaux = nbenti*(nbcomp-1)
 401         laux = adress(nbcomp)-1
 402 cgn      write (ulsort,90002) 'nbenti*(nbcomp-1)', kaux
 403 cgn      write (ulsort,90002) 'laux', laux
 404         do 32311 , jaux = 1 , nbencf
 405           tbiaux(kaux+jaux) = imem(laux+jaux)
 406 32311   continue
 407 c
 408         do 32312 , jaux = nbencf+1, nbenti
 409           tbiaux(kaux+jaux) = 0
 410 32312   continue
 411 c
 412 c 3.2.3.2. ==> Valeurs suivantes
 413 c
 414         do 323 , iaux = 2 , nbinsu
 415 c
 416           laux = laux + nbencf
 417           do 3232 , jaux = 1 , nbencf
 418             tbiaux(kaux+jaux) = 10*tbiaux(kaux+jaux) + imem(laux+jaux)
 419  3232     continue
 420 c
 421   323   continue
 422 c
 423       endif
 424 c
 425 c 3.3. ==> Ecriture des valeurs du champ
 426 c
 427 #ifdef _DEBUG_HOMARD_
 428       write (ulsort,90002) '3.3. Ecriture des valeurs ; codret', codret
 429 #endif
 430 c
 431       if ( codret.eq.0 ) then
 432 c
 433 #ifdef _DEBUG_HOMARD_
 434       write (ulsort,texte(langue,3)) 'MFDIVW', nompro
 435 #endif
 436       call mfdivw ( idfmed, nomcha,
 437      >              numdt, numit, instan,
 438      >              typent, typgeo, ednoin, edall,
 439      >              nbenti, tbiaux, codret )
 440 c
 441       if ( codret.ne.0 ) then
 442         write (ulsort,texte(langue,19)) nomcha
 443       endif
 444 c
 445       endif
 446 c
 447 c====
 448 c 4. Ecriture sous forme de profil pour les informations supplementaires
 449 c====
 450 #ifdef _DEBUG_HOMARD_
 451       write (ulsort,90002) '4. info supp ; codret', codret
 452       write (ulsort,90002) 'lgins2', lgins2
 453 #endif
 454 c
 455       if ( lgins2.gt.0 ) then
 456 c
 457       if ( codret.eq.0 ) then
 458 c
 459       noprof = blan64
 460 c                    12                      34567890
 461       noprof(1:10) = suffix(3,typenh)(1:2)//'InfoSup2'
 462 #ifdef _DEBUG_HOMARD_
 463       write (ulsort,90003) 'Ecriture du profil', noprof
 464       write (ulsort,90002) 'Valeurs',
 465      >      (imem(adins2+iaux),iaux=0,min(lgins2-1,9))
 466 #endif
 467 c
 468 #ifdef _DEBUG_HOMARD_
 469       write (ulsort,texte(langue,3)) 'MPFPRW', nompro
 470 #endif
 471       call mpfprw ( idfmed, noprof, lgins2, imem(adins2), codret )
 472 c
 473       endif
 474 c
 475       endif
 476 c
 477 c====
 478 c 5. la fin
 479 c====
 480 c
 481       if ( codret.ne.0 ) then
 482 c
 483 #include "envex2.h"
 484 c
 485       write (ulsort,texte(langue,1)) 'Sortie', nompro
 486       write (ulsort,texte(langue,2)) codret
 487       write (ulsort,*) mess14(langue,4,typenh)
 488 c
 489       endif
 490 c
 491 #ifdef _DEBUG_HOMARD_
 492       write (ulsort,texte(langue,1)) 'Sortie', nompro
 493       call dmflsh (iaux)
 494 #endif
 495 c
 496       end