src/tool/ES_HOMARD/esecs2.F

   1       subroutine esecs2 ( idfmed,
   2      >                    nomail,
   3      >                    ulsort, langue, codret)
   4 c
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c  Entree-Sortie : ECriture des informations Supplementaires - 2
  26 c  -      -        --                        -                 -
  27 c ______________________________________________________________________
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . idfmed . e   .   1    . identificateur du fichier MED              .
  31 c . nomail . e   . char*8 . structure du maillage a ecrire             .
  32 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  33 c . langue . e   .    1   . langue des messages                        .
  34 c .        .     .        . 1 : francais, 2 : anglais                  .
  35 c . codret . es  .    1   . code de retour des modules                 .
  36 c .        .     .        . 0 : pas de probleme                        .
  37 c ______________________________________________________________________
  38 c
  39 c====
  40 c 0. declarations et dimensionnement
  41 c====
  42 c
  43 c 0.1. ==> generalites
  44 c
  45       implicit none
  46       save
  47 c
  48       character*6 nompro
  49       parameter ( nompro = 'ESECS2' )
  50 c
  51 #include "nblang.h"
  52 #include "consts.h"
  53 c
  54 c 0.2. ==> communs
  55 c
  56 #include "envex1.h"
  57 #include "gmenti.h"
  58 c
  59 #include "enti01.h"
  60 c
  61 c 0.3. ==> arguments
  62 c
  63       integer*8 idfmed
  64 c
  65       character*8 nomail
  66 c
  67       integer ulsort, langue, codret
  68 c
  69 c 0.4. ==> variables locales
  70 c
  71       integer iaux, jaux, kaux
  72       integer typenh
  73       integer nbenac, nbento, adenho, adenca
  74       integer codre0
  75 c
  76       integer nbattx
  77       parameter ( nbattx = 19 )
  78       integer tabaux(nbattx)
  79 c
  80       logical afaire
  81 c
  82       character*8 saux08
  83       character*8 norenu
  84       character*64 noprof
  85 c
  86       integer nbmess
  87       parameter ( nbmess = 150 )
  88       character*80 texte(nblang,nbmess)
  89 c ______________________________________________________________________
  90 c
  91 c====
  92 c 1. initialisation
  93 c====
  94 c
  95 #include "impr01.h"
  96 c
  97 #ifdef _DEBUG_HOMARD_
  98       write (ulsort,texte(langue,1)) 'Entree', nompro
  99       call dmflsh (iaux)
 100 #endif
 101 c
 102       texte(1,4) = '(''... Ecriture des renumerotations'')'
 103       texte(1,7) = '(''Premieres valeurs : '',10i6)'
 104 c
 105       texte(2,4) = '(''... Writings of numbering'')'
 106       texte(2,7) = '(''First values : '',10i6)'
 107 c
 108 #include "impr03.h"
 109 c
 110 #include "esimpr.h"
 111 c
 112 #ifdef _DEBUG_HOMARD_
 113       write (ulsort,texte(langue,4))
 114 #endif
 115 c
 116 c====
 117 c 2. La renumerotation existe-t-elle ?
 118 c====
 119 c
 120       if ( codret.eq.0 ) then
 121 c
 122       call gmobal ( nomail//'.RenuMail', jaux )
 123 c
 124       if ( jaux.eq.1 ) then
 125         call gmnomc ( nomail//'.RenuMail', norenu, codret )
 126         afaire = .true.
 127       else
 128         afaire = .false.
 129       endif
 130 c
 131       endif
 132 c
 133 c====
 134 c 3. Ecriture des renumerotations sous forme de profil
 135 c====
 136 c
 137       if ( afaire ) then
 138 c
 139 c 3.1. ==> Les renumerotations des entites
 140 c
 141       if ( codret.eq.0 ) then
 142 c
 143       do 31 , typenh = -1 , 7
 144 c
 145 c 3.1.1. ==> La renumerotation existe-t-elle ?
 146 c          Si non, on passe a l'entite suivante
 147 c
 148         if ( codret.eq.0 ) then
 149 c
 150         saux08 = suffix(3,typenh)(1:2)//'HOMARD'
 151         call gmobal ( norenu//'.'//saux08, jaux )
 152         if ( jaux.ne.2 ) then
 153           goto 31
 154         endif
 155 c
 156         endif
 157 c
 158 c 3.1.2. ==> Nombre et adresse
 159 c
 160         if ( codret.eq.0 ) then
 161 c
 162         iaux = typenh
 163         jaux = 10
 164 #ifdef _DEBUG_HOMARD_
 165         write (ulsort,texte(langue,3)) 'UTRE03', nompro
 166 #endif
 167         call utre03 ( iaux, jaux, norenu,
 168      >                nbenac, nbento, adenho, adenca,
 169      >                ulsort, langue, codret)
 170 c
 171         endif
 172 c
 173 c 3.1.3. ==> Ecriture si la longueur n'est pas nulle
 174 c
 175         if ( nbenac.gt.0 ) then
 176 c
 177           if ( codret.eq.0 ) then
 178 c
 179           noprof = blan64
 180           noprof(1:8) = saux08
 181 c
 182 #ifdef _DEBUG_HOMARD_
 183           write (ulsort,texte(langue,61)) noprof
 184           write (ulsort,texte(langue,62)) nbenac
 185           write (ulsort,texte(langue,7))
 186      >   (imem(adenho+jaux-1), jaux = 1, min(10,nbenac))
 187 #endif
 188 c
 189 #ifdef _DEBUG_HOMARD_
 190       write (ulsort,texte(langue,3)) 'MPFPRW', nompro
 191 #endif
 192           call mpfprw ( idfmed, noprof, nbenac, imem(adenho), codret )
 193 c
 194           endif
 195 c
 196         endif
 197 c
 198    31 continue
 199 c
 200       endif
 201 c
 202 c 3.2. ==> La branche des nombres lies aux renumerotations
 203 c 3.2.1. ==> Longueur et adresse
 204 c
 205       if ( codret.eq.0 ) then
 206 c
 207       saux08 = 'Nombres '
 208       call gmadoj ( norenu//'.'//saux08, jaux, kaux, codret )
 209 c
 210       endif
 211 c
 212 c 3.2.2. ==> Ecriture
 213 c
 214       if ( codret.eq.0 ) then
 215 c
 216       noprof = blan64
 217       noprof(1:8) = saux08
 218 c
 219 #ifdef _DEBUG_HOMARD_
 220       write (ulsort,texte(langue,61)) noprof
 221       write (ulsort,texte(langue,62)) kaux
 222       write (ulsort,texte(langue,7)) (imem(jaux+iaux-1), iaux = 1, kaux)
 223 #endif
 224 c
 225 #ifdef _DEBUG_HOMARD_
 226       write (ulsort,texte(langue,3)) 'MPFPRW', nompro
 227 #endif
 228       call mpfprw ( idfmed, noprof, kaux, imem(jaux), codret )
 229 c
 230       endif
 231 c
 232 c 3.3. ==> Les attributs lies aux renumerotations
 233 c 3.3.1. ==> Les valeurs
 234 c
 235       if ( codret.eq.0 ) then
 236 c
 237       do 331 , iaux = 1 , nbattx
 238 c
 239         jaux = iaux
 240         call gmliat ( norenu, jaux, kaux, codre0 )
 241         tabaux(iaux) = kaux
 242 c
 243         codret = max ( abs(codre0), codret )
 244 c
 245   331 continue
 246 c
 247       endif
 248 c
 249 c 3.3.2. ==> Ecriture
 250 c
 251       if ( codret.eq.0 ) then
 252 c
 253       noprof = blan64
 254 c                     1234567890123456789
 255       noprof(1:19) = 'Attributs_de_norenu'
 256 c
 257 #ifdef _DEBUG_HOMARD_
 258       write (ulsort,texte(langue,61)) noprof
 259       write (ulsort,texte(langue,62)) nbattx
 260       write (ulsort,texte(langue,7)) (tabaux(jaux), jaux = 1, nbattx)
 261 #endif
 262 c
 263       kaux = nbattx
 264 #ifdef _DEBUG_HOMARD_
 265       write (ulsort,texte(langue,3)) 'MPFPRW', nompro
 266 #endif
 267       call mpfprw ( idfmed, noprof, kaux, tabaux, codret )
 268 c
 269       endif
 270 c
 271       endif
 272 c
 273 c====
 274 c 4. la fin
 275 c====
 276 c
 277       if ( codret.ne.0 ) then
 278 c
 279 #include "envex2.h"
 280 c
 281       write (ulsort,texte(langue,1)) 'Sortie', nompro
 282       write (ulsort,texte(langue,2)) codret
 283 c
 284       endif
 285 c
 286 #ifdef _DEBUG_HOMARD_
 287       write (ulsort,texte(langue,1)) 'Sortie', nompro
 288       call dmflsh (iaux)
 289 #endif
 290 c
 291       end