src/tool/ES_HOMARD/esecs3.F

   1       subroutine esecs3 ( idfmed,
   2      >                    nhnoeu,
   3      >                    nhmapo, nharet, nhtria, nhquad,
   4      >                    nhtetr, nhhexa, nhpyra, nhpent,
   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 : ECriture des informations Supplementaires - 3
  28 c  -      -        --                        -                 -
  29 c ______________________________________________________________________
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . idfmed . e   .   1    . identificateur du fichier MED              .
  33 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  34 c . langue . e   .    1   . langue des messages                        .
  35 c .        .     .        . 1 : francais, 2 : anglais                  .
  36 c . codret . es  .    1   . code de retour des modules                 .
  37 c .        .     .        . 0 : pas de probleme                        .
  38 c ______________________________________________________________________
  39 c
  40 c====
  41 c 0. declarations et dimensionnement
  42 c====
  43 c
  44 c 0.1. ==> generalites
  45 c
  46       implicit none
  47       save
  48 c
  49       character*6 nompro
  50       parameter ( nompro = 'ESECS3' )
  51 c
  52 #include "nblang.h"
  53 #include "consts.h"
  54 c
  55 c 0.2. ==> communs
  56 c
  57 #include "envex1.h"
  58 #include "gmenti.h"
  59 c
  60 #include "impr02.h"
  61 #include "enti01.h"
  62 #include "nombno.h"
  63 #include "nombmp.h"
  64 #include "nombar.h"
  65 #include "nombtr.h"
  66 #include "nombqu.h"
  67 #include "nombte.h"
  68 #include "nombpy.h"
  69 #include "nombhe.h"
  70 #include "nombpe.h"
  71 c
  72 c 0.3. ==> arguments
  73 c
  74       integer*8 idfmed
  75 c
  76       character*8 nhnoeu
  77       character*8 nhmapo, nharet, nhtria, nhquad
  78       character*8 nhtetr, nhhexa, nhpyra, nhpent
  79 c
  80       integer ulsort, langue, codret
  81 c
  82 c 0.4. ==> variables locales
  83 c
  84       integer iaux
  85 #ifdef _DEBUG_HOMARD_
  86       integer jaux
  87 #endif
  88       integer typenh
  89       integer nbenti
  90       integer codre1, codre2, codre3
  91       integer codre0
  92       integer tabaux(3)
  93       integer adress(2), lgtab(2)
  94       logical tabsim
  95 c
  96       character*1 saux01(2)
  97       character*8 nhenti
  98       character*64 noprof
  99 c
 100       integer nbmess
 101       parameter ( nbmess = 150 )
 102       character*80 texte(nblang,nbmess)
 103 c
 104 c 0.5. ==> initialisation
 105 c
 106       data saux01 / 'A', 'B' /
 107 c ______________________________________________________________________
 108 c
 109 c====
 110 c 1. initialisation
 111 c====
 112 c
 113 #include "impr01.h"
 114 c
 115 #ifdef _DEBUG_HOMARD_
 116       write (ulsort,texte(langue,1)) 'Entree', nompro
 117       call dmflsh (iaux)
 118 #endif
 119 c
 120       texte(1,4) = '(''... Ecriture des recollements'')'
 121       texte(1,5) = '(/,''..... pour les '',a)'
 122       texte(1,7) = '(''Premieres valeurs : '',10i6)'
 123 c
 124       texte(2,4) = '(''... Writings of gluing'')'
 125       texte(2,5) = '(/,''..... for '',a)'
 126       texte(2,7) = '(''First values : '',10i6)'
 127 c
 128 #include "impr03.h"
 129 c
 130 #include "esimpr.h"
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133       write (ulsort,texte(langue,4))
 134 #endif
 135 c
 136 c====
 137 c 2. Ecriture par type des recollements sous forme de profil
 138 c====
 139 c
 140       do 20 , typenh = -1 , 7
 141 c
 142 c 2.1. ==> decodage des caracteristiques
 143 c
 144         if ( codret.eq.0 ) then
 145 c
 146         if ( typenh.eq.-1 ) then
 147           nbenti = nbnoto
 148           nhenti = nhnoeu
 149         elseif ( typenh.eq.0 ) then
 150           nbenti = nbmpto
 151           nhenti = nhmapo
 152         elseif ( typenh.eq.1 ) then
 153           nbenti = nbarto
 154           nhenti = nharet
 155         elseif ( typenh.eq.2 ) then
 156           nbenti = nbtrto
 157           nhenti = nhtria
 158        elseif ( typenh.eq.3 ) then
 159           nbenti = nbteto
 160           nhenti = nhtetr
 161         elseif ( typenh.eq.4 ) then
 162           nbenti = nbquto
 163           nhenti = nhquad
 164         elseif ( typenh.eq.5 ) then
 165           nbenti = nbpyto
 166           nhenti = nhpyra
 167         elseif ( typenh.eq.6 ) then
 168           nbenti = nbheto
 169           nhenti = nhhexa
 170         else
 171           nbenti = nbpeto
 172           nhenti = nhpent
 173         endif
 174 c
 175         endif
 176 c
 177         if ( nbenti.eq.0 ) then
 178           goto 20
 179         endif
 180 c
 181 c 2.2. ==> Le recollement existe-t-il ?
 182 c          Si non, on passe a l'entite suivante
 183 c
 184         if ( codret.eq.0 ) then
 185 c
 186         call gmobal ( nhenti//'.Recollem', codre0 )
 187         if ( codre0.eq.1 ) then
 188           tabsim = .false.
 189         elseif ( codre0.eq.2 ) then
 190           tabsim = .true.
 191         else
 192           goto 20
 193         endif
 194 c
 195         endif
 196 c
 197 c 2.3. ==> decodage dans le cas d'un objet simple
 198 c
 199 #ifdef _DEBUG_HOMARD_
 200         write (ulsort,texte(langue,5)) mess14(langue,3,typenh)
 201 #endif
 202 c
 203 c 2.3.1. ==> decodage dans le cas d'un objet simple
 204 c
 205         if ( tabsim ) then
 206 c
 207           if ( codret.eq.0 ) then
 208 c
 209 cc          call gmprsx ( nompro, nhenti )
 210 cc          call gmprsx ( nompro, nhenti//'.Recollem' )
 211           call gmadoj ( nhenti//'.Recollem',
 212      >                  adress(1), lgtab(1), codre0 )
 213 c
 214           codret = max ( abs(codre0), codret )
 215           lgtab(2) = 0
 216 c
 217           endif
 218 c
 219         else
 220 c
 221 c 2.3.2. ==> decodage dans le cas d'un objet structure
 222 c
 223           if ( codret.eq.0 ) then
 224 c
 225           call gmliat ( nhenti//'.Recollem', 1, tabaux(1), codre1 )
 226           call gmliat ( nhenti//'.Recollem', 2, tabaux(2), codre2 )
 227           call gmliat ( nhenti//'.Recollem', 3, tabaux(3), codre3 )
 228 c
 229           codre0 = min ( codre1, codre2, codre3 )
 230           codret = max ( abs(codre0), codret,
 231      >                   codre1, codre2, codre3 )
 232 c
 233           endif
 234 c
 235           if ( codret.eq.0 ) then
 236 c
 237           if ( tabaux(1).gt.0 ) then
 238 c
 239             call gmadoj ( nhenti//'.Recollem.ListeA',
 240      >                    adress(1), lgtab(1), codre1 )
 241             call gmadoj ( nhenti//'.Recollem.ListeB',
 242      >                    adress(2), lgtab(2), codre2 )
 243 c
 244             codre0 = min ( codre1, codre2 )
 245             codret = max ( abs(codre0), codret,
 246      >                     codre1, codre2 )
 247 c
 248           else
 249 c
 250             lgtab(1) = 0
 251             lgtab(2) = 0
 252 c
 253           endif
 254 c
 255           endif
 256 c
 257         endif
 258 c
 259 c 2.4. ==> Ecriture
 260 c
 261         noprof = blan64
 262         noprof(1:2) = suffix(3,typenh)(1:2)
 263 c                       3456789012
 264         noprof(3:12) = '_Recollem_'
 265 c
 266 c 2.4.1. ==> Ecriture des attributs de l'objet structure
 267 c
 268         if ( .not.tabsim ) then
 269 c
 270           if ( codret.eq.0 ) then
 271 c
 272 c                          345678901
 273           noprof(13:21) = 'Attributs'
 274 c
 275           iaux = 3
 276 #ifdef _DEBUG_HOMARD_
 277       write (ulsort,texte(langue,61)) noprof
 278       write (ulsort,texte(langue,62)) iaux
 279       write (ulsort,texte(langue,7))(tabaux(jaux),jaux=1,min(iaux,10))
 280 #endif
 281 c
 282 #ifdef _DEBUG_HOMARD_
 283       write (ulsort,texte(langue,3)) 'MPFPRW_attributs', nompro
 284 #endif
 285           call mpfprw ( idfmed, noprof, iaux, tabaux, codret )
 286 c
 287           endif
 288 c
 289         endif
 290 c
 291 c 2.4.2. ==> Ecriture des listes
 292 c
 293         do 242 , iaux = 1 , 2
 294 c
 295           if ( lgtab(iaux).gt.0 ) then
 296 c
 297             if ( codret.eq.0 ) then
 298 c
 299 c                            34567   8              901
 300             noprof(13:21) = 'Liste'//saux01(iaux)//'   '
 301 c
 302 #ifdef _DEBUG_HOMARD_
 303       write (ulsort,texte(langue,61)) noprof
 304       write (ulsort,texte(langue,62)) lgtab(iaux)
 305       write (ulsort,texte(langue,7))
 306      >(imem(adress(iaux+jaux)),jaux=0,min(lgtab(iaux)-1,9))
 307 #endif
 308 c
 309 #ifdef _DEBUG_HOMARD_
 310       write (ulsort,texte(langue,3)) 'MPFPRW_'//saux01(iaux), nompro
 311 #endif
 312             call mpfprw ( idfmed, noprof,
 313      >                    lgtab(iaux), imem(adress(iaux)), codret )
 314 c
 315             endif
 316 c
 317           endif
 318 c
 319   242   continue
 320 c
 321    20 continue
 322 c
 323 c====
 324 c 3. la fin
 325 c====
 326 c
 327       if ( codret.ne.0 ) then
 328 c
 329 #include "envex2.h"
 330 c
 331       write (ulsort,texte(langue,1)) 'Sortie', nompro
 332       write (ulsort,texte(langue,2)) codret
 333 c
 334       endif
 335 c
 336 #ifdef _DEBUG_HOMARD_
 337       write (ulsort,texte(langue,1)) 'Sortie', nompro
 338       call dmflsh (iaux)
 339 #endif
 340 c
 341       end