src/tool/ES_HOMARD/esemh0.F

   1       subroutine esemh0 ( nomail,
   2      >                    ulsort, langue, codret)
   3 c ______________________________________________________________________
   4 c
   5 c                             H O M A R D
   6 c
   7 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   8 c
   9 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  10 c aupres des huissiers de justice Simart et Lavoir a Clamart
  11 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  12 c aupres des huissiers de justice
  13 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  14 c
  15 c    HOMARD est une marque deposee d'Electricite de France
  16 c
  17 c Copyright EDF 1996
  18 c Copyright EDF 1998
  19 c Copyright EDF 2002
  20 c Copyright EDF 2020
  21 c ______________________________________________________________________
  22 c
  23 c  Entree-Sortie : Ecriture du Maillage Homard - 0
  24 c  -      -        -           -        -        -
  25 c ______________________________________________________________________
  26 c    Attention : esemh0 et eslmh3 doivent evoluer en parallelle
  27 c ______________________________________________________________________
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . nomail . e   . char*8 . nom du maillage a ecrire                   .
  31 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  32 c . langue . e   .    1   . langue des messages                        .
  33 c .        .     .        . 1 : francais, 2 : anglais                  .
  34 c . codret . es  .    1   . code de retour des modules                 .
  35 c .        .     .        . 0 : pas de probleme                        .
  36 c ______________________________________________________________________
  37 c
  38 c====
  39 c 0. declarations et dimensionnement
  40 c====
  41 c
  42 c 0.1. ==> generalites
  43 c
  44       implicit none
  45       save
  46 c
  47       character*6 nompro
  48       parameter ( nompro = 'ESEMH0' )
  49 c
  50 #include "nblang.h"
  51 c
  52 c 0.2. ==> communs
  53 c
  54 #include "envex1.h"
  55 c
  56 #include "gmenti.h"
  57 c
  58 #include "dicfen.h"
  59 #include "nbfami.h"
  60 #include "nombno.h"
  61 #include "nombmp.h"
  62 #include "nombar.h"
  63 #include "nombtr.h"
  64 #include "nombqu.h"
  65 #include "nombte.h"
  66 #include "nombhe.h"
  67 #include "nombpe.h"
  68 #include "nombpy.h"
  69 #include "envada.h"
  70 c
  71 c 0.3. ==> arguments
  72 c
  73       character*8 nomail
  74 c
  75       integer ulsort, langue, codret
  76 c
  77 c 0.4. ==> variables locales
  78 c
  79       integer iaux
  80       integer adinse
  81       integer codre1, codre2
  82 c
  83       logical existe(2)
  84 c
  85       integer nbmess
  86       parameter ( nbmess = 10 )
  87       character*80 texte(nblang,nbmess)
  88 c ______________________________________________________________________
  89 c
  90 c====
  91 c 1. les initialisations
  92 c====
  93 c
  94 #include "impr01.h"
  95 c
  96 #ifdef _DEBUG_HOMARD_
  97       write (ulsort,texte(langue,1)) 'Entree', nompro
  98       call dmflsh (iaux)
  99 #endif
 100 c
 101       texte(1,4) = '(''Enregistrement des communs.'')'
 102 c
 103       texte(2,4) = '(''Recording of the commons'')'
 104 c
 105 #include "impr03.h"
 106 c
 107 c====
 108 c 2. controle des allocations deja presentes
 109 c    comme elles n'ont pu se faire qu'ici, on ne verifie pas les tailles
 110 c====
 111 #ifdef _DEBUG_HOMARD_
 112       call gmprsx (nompro, nomail )
 113       call gmprsx (nompro, nomail//'.InfoSupE' )
 114       call gmprsx (nompro, nomail//'.InfoSupE.Tab1' )
 115       call gmprsx (nompro, nomail//'.InfoSupE.Tab2' )
 116       call gmprsx (nompro, nomail//'.InfoSupE.Tab3' )
 117       call gmprsx (nompro, nomail//'.InfoSupE.Tab4' )
 118       call gmprsx (nompro, nomail//'.InfoSupE.Tab5' )
 119       call gmprsx (nompro, nomail//'.InfoSupE.Tab6' )
 120       call gmprsx (nompro, nomail//'.InfoSupE.Tab7' )
 121       call gmprsx (nompro, nomail//'.InfoSupE.Tab8' )
 122       call gmprsx (nompro, nomail//'.InfoSupE.Tab9' )
 123       call gmprsx (nompro, nomail//'.InfoSupE.Tab10' )
 124       call gmprsx (nompro, nomail//'.InfoSupS' )
 125       call gmprsx (nompro, nomail//'.InfoSupS.Tab2' )
 126       call gmprsx (nompro, nomail//'.InfoSupS.Tab3' )
 127       call gmprsx (nompro, nomail//'.InfoSupS.Tab4' )
 128       call gmprsx (nompro, nomail//'.InfoSupS.Tab5' )
 129       call gmprsx (nompro, nomail//'.InfoSupS.Tab10' )
 130 #endif
 131 c
 132       if ( codret.eq.0 ) then
 133 c
 134       call gmobal ( nomail//'.InfoSupE.Tab1', codre1 )
 135       if ( codre1.eq.2 ) then
 136         existe(1) = .true.
 137       elseif ( codre1.eq.0 ) then
 138         existe(1) = .false.
 139       else
 140         codret = 2
 141       endif
 142 C
 143       call gmobal ( nomail//'.InfoSupE.Tab2', codre2 )
 144       if ( codre2.eq.2 ) then
 145         call gmdtoj ( nomail//'.InfoSupE.Tab2', codret )
 146       elseif ( codre2.ne.0 ) then
 147         codret = 2
 148       endif
 149 c
 150       endif
 151 c
 152 c====
 153 c 3. Allocations de la branche pour les informations en entier
 154 c====
 155 #ifdef _DEBUG_HOMARD_
 156       write (ulsort,90002) '3 allocation : codret', codret
 157 #endif
 158 c
 159       if ( codret.eq.0 ) then
 160 c
 161       if ( .not.existe(1) ) then
 162         iaux = 12 + 2 + 12 + 12 + 9 + 22 + 9 + 9 + 18 + 9 + 8 + 27 + 5
 163         call gmaloj ( nomail//'.InfoSupE.Tab1',
 164      >                ' ', iaux, adinse, codret )
 165       else
 166         call gmadoj ( nomail//'.InfoSupE.Tab1', adinse, iaux, codret )
 167       endif
 168 c
 169       endif
 170 c
 171       if ( codret.eq.0 ) then
 172 c
 173       call gmecat ( nomail//'.InfoSupE', 1, iaux, codret )
 174 c
 175       endif
 176 c
 177 c====
 178 c 4. transfert des infos des communs vers la structure
 179 c====
 180 #ifdef _DEBUG_HOMARD_
 181       write (ulsort,90002) '4 transfert : codret', codret
 182 #endif
 183 c
 184       if ( codret.eq.0 ) then
 185 c
 186        iaux = adinse - 1
 187 c nombno
 188        imem(iaux+1) = nbnois
 189        imem(iaux+2) = nbnoei
 190        imem(iaux+3) = nbnoma
 191        imem(iaux+4) = nbnomp
 192        imem(iaux+5) = nbnop1
 193        imem(iaux+6) = nbnop2
 194        imem(iaux+7) = nbnoim
 195        imem(iaux+8) = nbnoto
 196        imem(iaux+9) = nbpnho
 197        imem(iaux+10) = numip1
 198        imem(iaux+11) = numap1
 199        imem(iaux+12) = nbnoin
 200        iaux = iaux + 12
 201 c nombmp
 202        imem(iaux+1) = nbmpto
 203        imem(iaux+2) = nbppho
 204        iaux = iaux + 2
 205 c nombar
 206        imem(iaux+1) = nbarac
 207        imem(iaux+2) = nbarde
 208        imem(iaux+3) = nbart2
 209        imem(iaux+4) = nbarq2
 210        imem(iaux+5) = nbarq3
 211        imem(iaux+6) = nbarq5
 212        imem(iaux+7) = nbarin
 213        imem(iaux+8) = nbarma
 214        imem(iaux+9) = nbarpe
 215        imem(iaux+10) = nbarto
 216        imem(iaux+11) = nbfaar
 217        imem(iaux+12) = nbpaho
 218        iaux = iaux + 12
 219 c nombtr
 220        imem(iaux+1) = nbtrac
 221        imem(iaux+2) = nbtrde
 222        imem(iaux+3) = nbtrt2
 223        imem(iaux+4) = nbtrq3
 224        imem(iaux+5) = nbtrhc
 225        imem(iaux+6) = nbtrpc
 226        imem(iaux+7) = nbtrtc
 227        imem(iaux+8) = nbtrma
 228        imem(iaux+9) = nbtrpe
 229        imem(iaux+10) = nbtrto
 230        imem(iaux+11) = nbptho
 231        imem(iaux+12) = nbtrri
 232        iaux = iaux + 12
 233 c nombqu
 234        imem(iaux+1) = nbquac
 235        imem(iaux+2) = nbqude
 236        imem(iaux+3) = nbquma
 237        imem(iaux+4) = nbquq2
 238        imem(iaux+5) = nbquq5
 239        imem(iaux+6) = nbqupe
 240        imem(iaux+7) = nbquto
 241        imem(iaux+8) = nbpqho
 242        imem(iaux+9) = nbquri
 243        iaux = iaux + 9
 244 c nombte
 245        imem(iaux+1) = nbteac
 246        imem(iaux+2) = nbtea2
 247        imem(iaux+3) = nbtea4
 248        imem(iaux+4) = nbtede
 249        imem(iaux+5) = nbtef4
 250        imem(iaux+6) = nbteh1
 251        imem(iaux+7) = nbteh2
 252        imem(iaux+8) = nbteh3
 253        imem(iaux+9) = nbteh4
 254        imem(iaux+10) = nbtep0
 255        imem(iaux+11) = nbtep1
 256        imem(iaux+12) = nbtep2
 257        imem(iaux+13) = nbtep3
 258        imem(iaux+14) = nbtep4
 259        imem(iaux+15) = nbtep5
 260        imem(iaux+16) = nbtedh
 261        imem(iaux+17) = nbtedp
 262        imem(iaux+18) = nbtema
 263        imem(iaux+19) = nbtepe
 264        imem(iaux+20) = nbteto
 265        imem(iaux+21) = nbtecf
 266        imem(iaux+22) = nbteca
 267        iaux = iaux + 22
 268 c nombhe
 269        imem(iaux+1) = nbheac
 270        imem(iaux+2) = nbheco
 271        imem(iaux+3) = nbhede
 272        imem(iaux+4) = nbhedh
 273        imem(iaux+5) = nbhema
 274        imem(iaux+6) = nbhepe
 275        imem(iaux+7) = nbheto
 276        imem(iaux+8) = nbhecf
 277        imem(iaux+9) = nbheca
 278        iaux = iaux + 9
 279 c nombpe
 280        imem(iaux+1) = nbpeac
 281        imem(iaux+2) = nbpeco
 282        imem(iaux+3) = nbpede
 283        imem(iaux+4) = nbpedp
 284        imem(iaux+5) = nbpema
 285        imem(iaux+6) = nbpepe
 286        imem(iaux+7) = nbpeto
 287        imem(iaux+8) = nbpecf
 288        imem(iaux+9) = nbpeca
 289        iaux = iaux + 9
 290 c nombpy
 291        imem(iaux+1) = nbpyac
 292        imem(iaux+2) = nbpyh1
 293        imem(iaux+3) = nbpyh2
 294        imem(iaux+4) = nbpyh3
 295        imem(iaux+5) = nbpyh4
 296        imem(iaux+6) = nbpyp0
 297        imem(iaux+7) = nbpyp1
 298        imem(iaux+8) = nbpyp2
 299        imem(iaux+9) = nbpyp3
 300        imem(iaux+10) = nbpyp4
 301        imem(iaux+11) = nbpyp5
 302        imem(iaux+12) = nbpydh
 303        imem(iaux+13) = nbpydp
 304        imem(iaux+14) = nbpyma
 305        imem(iaux+15) = nbpype
 306        imem(iaux+16) = nbpyto
 307        imem(iaux+17) = nbpycf
 308        imem(iaux+18) = nbpyca
 309        iaux = iaux + 18
 310 c nbfami
 311        imem(iaux+1) = nbfnoe
 312        imem(iaux+2) = nbfmpo
 313        imem(iaux+3) = nbfare
 314        imem(iaux+4) = nbftri
 315        imem(iaux+5) = nbfqua
 316        imem(iaux+6) = nbftet
 317        imem(iaux+7) = nbfhex
 318        imem(iaux+8) = nbfpyr
 319        imem(iaux+9) = nbfpen
 320        iaux = iaux + 9
 321 c dicfen
 322        imem(iaux+ 1) = ncffno
 323        imem(iaux+ 2) = ncffmp
 324        imem(iaux+ 3) = ncffar
 325        imem(iaux+ 4) = ncfftr
 326        imem(iaux+ 5) = ncffqu
 327        imem(iaux+ 6) = ncffte
 328        imem(iaux+ 7) = ncffhe
 329        imem(iaux+ 8) = ncffpy
 330        imem(iaux+ 9) = ncffpe
 331        imem(iaux+10) = ncefno
 332        imem(iaux+11) = ncefmp
 333        imem(iaux+12) = ncefar
 334        imem(iaux+13) = nceftr
 335        imem(iaux+14) = ncefqu
 336        imem(iaux+15) = nctfno
 337        imem(iaux+16) = nctfmp
 338        imem(iaux+17) = nctfar
 339        imem(iaux+18) = nctftr
 340        imem(iaux+19) = nctfqu
 341        imem(iaux+20) = nctfte
 342        imem(iaux+21) = nctfhe
 343        imem(iaux+22) = nctfpy
 344        imem(iaux+23) = nctfpe
 345        imem(iaux+24) = ncxfno
 346        imem(iaux+25) = ncxfar
 347        imem(iaux+26) = ncxftr
 348        imem(iaux+27) = ncxfqu
 349        iaux = iaux + 27
 350 c envada
 351        imem(iaux+1) = nbiter
 352        imem(iaux+2) = nivinf
 353        imem(iaux+3) = nivsup
 354        imem(iaux+4) = niincf
 355        imem(iaux+5) = nisucf
 356        iaux = iaux + 5
 357 c
 358       endif
 359 c
 360 #ifdef _DEBUG_HOMARD_
 361       write (ulsort,90002) 'Apres remplissage InfoSupE : codret',
 362      > codret
 363       call gmprsx (nompro, nomail )
 364       call gmprsx (nompro, nomail//'.InfoSupE' )
 365       call gmprsx (nompro, nomail//'.InfoSupE.Tab1' )
 366       call gmprsx (nompro, nomail//'.InfoSupE.Tab2' )
 367 #endif
 368 c
 369 c====
 370 c 5. la fin
 371 c====
 372 c
 373       if ( codret.ne.0 ) then
 374 c
 375 #include "envex2.h"
 376 c
 377       write (ulsort,texte(langue,1)) 'Sortie', nompro
 378       write (ulsort,texte(langue,2)) codret
 379 c
 380       endif
 381 c
 382 #ifdef _DEBUG_HOMARD_
 383       write (ulsort,texte(langue,1)) 'Sortie', nompro
 384       call dmflsh (iaux)
 385 #endif
 386 c
 387       end