src/tool/ES_HOMARD/esecfs.F

   1       subroutine esecfs ( idfmed, nomamd,
   2      >                    nhsups,
   3      >                    numfam,
   4      >                    ltbsau, tbsaux,
   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 Familles Supplementaires
  28 c  -      -        --           -        -
  29 c ______________________________________________________________________
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . idfmed . e   .   1    . identificateur du fichier MED              .
  33 c . nomamd . e   . char64 . nom du maillage MED voulu                  .
  34 c . nhsups . e   . char*8 . informations supplementaires caracteres 8  .
  35 c . numfam . es  .   1    . numero de famille                          .
  36 c . ltbsau . e   .    1   . longueur allouee a tbsaux                  .
  37 c . tbsaux .     .    *   . tableau tampon caracteres                  .
  38 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  39 c . langue . e   .    1   . langue des messages                        .
  40 c .        .     .        . 1 : francais, 2 : anglais                  .
  41 c . codret . es  .    1   . code de retour des modules                 .
  42 c .        .     .        . 0 : pas de probleme                        .
  43 c ______________________________________________________________________
  44 c
  45 c====
  46 c 0. declarations et dimensionnement
  47 c====
  48 c
  49 c 0.1. ==> generalites
  50 c
  51       implicit none
  52       save
  53 c
  54       character*6 nompro
  55       parameter ( nompro = 'ESECFS' )
  56 c
  57 #include "nblang.h"
  58 #include "consts.h"
  59 c
  60 c 0.2. ==> communs
  61 c
  62 #include "envex1.h"
  63 c
  64 #include "gmstri.h"
  65 c
  66 c 0.3. ==> arguments
  67 c
  68       integer*8 idfmed
  69       integer numfam
  70       integer ltbsau
  71 c
  72       character*8 nhsups
  73       character*64 nomamd
  74       character*8 tbsaux(*)
  75 c
  76       integer ulsort, langue, codret
  77 c
  78 c 0.4. ==> variables locales
  79 c
  80 #include "meddc0.h"
  81 c
  82       integer iaux, jaux, kaux
  83       integer codre1, codre2
  84       integer codre0
  85       integer adress, nbval
  86       integer ngro
  87 c
  88       character*2 saux02
  89       character*32 saux32
  90       character*64 saux64
  91 c
  92       integer nbmess
  93       parameter ( nbmess = 150 )
  94       character*80 texte(nblang,nbmess)
  95 c ______________________________________________________________________
  96 c
  97 c====
  98 c 1. messages
  99 c====
 100 c
 101 #include "impr01.h"
 102 c
 103 #ifdef _DEBUG_HOMARD_
 104       write (ulsort,texte(langue,1)) 'Entree', nompro
 105       call dmflsh (iaux)
 106 #endif
 107 c
 108 #include "esimpr.h"
 109 c
 110       texte(1,4) = '(''. Ecriture des familles supplementaires'')'
 111       texte(1,5) = '(''... InfoSupS.Tab'',i2)'
 112       texte(1,81) = '(''Longueur allouee pour tbsaux    : '',i10)'
 113       texte(1,82) = '(''Longueur necessaire pour tbsaux : '',i10)'
 114 c
 115       texte(2,4) = '(''. Writings of aditional families'')'
 116       texte(2,5) = '(''... InfoSupS.Tab'',i2)'
 117       texte(2,81) = '(''Allocated length for tbsaux    : '',i10)'
 118       texte(2,82) = '(''Used length for tbsaux : '',i10)'
 119 c
 120 #include "impr03.h"
 121 c
 122  1002 format(10(a8,'+'))
 123 c
 124 #ifdef _DEBUG_HOMARD_
 125       write (ulsort,texte(langue,4))
 126       call gmprsx ( nompro, nhsups )
 127       call gmprsx ( nompro, nhsups//'.Tab2' )
 128       call gmprsx ( nompro, nhsups//'.Tab3' )
 129       call gmprsx ( nompro, nhsups//'.Tab4' )
 130       call gmprsx ( nompro, nhsups//'.Tab10' )
 131 c
 132 #endif
 133 c
 134 c====
 135 c 2. Ecriture
 136 c====
 137 c
 138       do 21 , iaux = 1 , 10
 139 c
 140 c 2.1. ==> decodage des caracteristiques
 141 #ifdef _DEBUG_HOMARD_
 142       write (ulsort,90002) '2.1. ==> decodage ; codret', codret
 143 #endif
 144 c
 145         if ( codret.eq.0 ) then
 146 #ifdef _DEBUG_HOMARD_
 147       write (ulsort,texte(langue,5)) iaux
 148 #endif
 149 c
 150         jaux = iaux
 151         call utench ( jaux, 'g', kaux, saux02,
 152      >                ulsort, langue, codret )
 153 c
 154         endif
 155 c
 156         if ( codret.eq.0 ) then
 157 c
 158         call gmobal ( nhsups//'.Tab'//saux02(1:kaux), codre0 )
 159 c
 160         if ( codre0.eq.2 ) then
 161 c
 162           call gmliat ( nhsups, jaux, nbval, codre1 )
 163           call gmadoj ( nhsups//'.Tab'//saux02(1:kaux),
 164      >                  adress, kaux, codre2 )
 165 c
 166           codre0 = min ( codre1, codre2 )
 167           codret = max ( abs(codre0), codret,
 168      >                   codre1, codre2 )
 169 c
 170         else
 171           goto 21
 172         endif
 173 c
 174         endif
 175 c
 176 c 2.2. ==> creation de la famille eventuelle
 177 c          La convention MED veut que le nom d'un groupe soit
 178 c          de taille 80
 179 #ifdef _DEBUG_HOMARD_
 180       write (ulsort,90002) '2.2. ==> creation ; codret', codret
 181 #endif
 182 cgn        call gmprsx ( nompro, nhsups//'.Tab'//saux02 )
 183 c
 184         if ( nbval.gt.0 ) then
 185 c
 186 c 2.2.1. ==> controle
 187 c
 188           if ( codret.eq.0 ) then
 189 #ifdef _DEBUG_HOMARD_
 190           write (ulsort,90002) 'nbval', nbval
 191 #endif
 192 c
 193           if ( (nbval+11).gt.ltbsau ) then
 194             call gmprsx ( nompro, nhsups )
 195             write (ulsort,texte(langue,81)) ltbsau
 196             write (ulsort,texte(langue,82)) nbval+11
 197             write (ulsort,*) 'Probleme pour Tab', saux02
 198             codret = 7
 199           endif
 200 c
 201           endif
 202 c
 203 c 2.2.2. ==> un premier groupe : le nombre de valeurs
 204 c
 205           if ( codret.eq.0 ) then
 206 c
 207           call utench ( nbval, 'd', jaux, saux32,
 208      >                  ulsort, langue, codret )
 209 c
 210           tbsaux(1) = 'Nombre d'
 211           tbsaux(2) = 'e valeur'
 212           tbsaux(3) = 's :     '
 213           tbsaux(4) = saux32( 1: 8)
 214           tbsaux(5) = saux32( 9:16)
 215           tbsaux(6) = saux32(17:24)
 216           tbsaux(7) = saux32(25:32)
 217           do 222 , jaux = 8, 10
 218             tbsaux(jaux) = blan08
 219   222     continue
 220 c
 221           endif
 222 c
 223 c 2.2.3. ==> les groupes suivants : le texte
 224 c
 225           if ( codret.eq.0 ) then
 226 c
 227           kaux = mod(nbval,10)
 228           if ( kaux.eq.0 ) then
 229             jaux = nbval/10
 230           else
 231             jaux = (nbval-kaux)/10 + 1
 232           endif
 233           ngro = jaux + 1
 234 c
 235           do 2231 , jaux = 1 , nbval
 236             tbsaux(10+jaux) = smem(adress+jaux-1)
 237  2231     continue
 238 c
 239           do 2232 , jaux = 10+nbval+1 , 10*ngro
 240             tbsaux(jaux) = blan08
 241  2232     continue
 242 c
 243           endif
 244 c
 245 c 2.2.4. ==> ecriture
 246 c
 247           if ( codret.eq.0 ) then
 248 c
 249           numfam = numfam - 1
 250           saux64 = blan64
 251 c                          123456789012
 252           saux64( 1:12) = 'InfoSupS_Tab'
 253           saux64(13:14) = saux02
 254 c
 255 #ifdef _DEBUG_HOMARD_
 256           write (ulsort,*) 'Famille ', saux64
 257           write (ulsort,90002) 'ngro', ngro
 258           do 224 , jaux = 1 , ngro
 259             write (ulsort,1002) (tbsaux(kaux),kaux=10*(jaux-1)+1,10*jaux)
 260   224     continue
 261 #endif
 262 #ifdef _DEBUG_HOMARD_
 263       write (ulsort,texte(langue,3)) 'MFACRE', nompro
 264 #endif
 265           call mfacre ( idfmed, nomamd, saux64, numfam,
 266      >                  ngro, tbsaux, codret )
 267 c
 268           endif
 269 c
 270         endif
 271 c
 272    21 continue
 273 c
 274 c====
 275 c 3. la fin
 276 c====
 277 c
 278       if ( codret.ne.0 ) then
 279 c
 280 #include "envex2.h"
 281 c
 282       write (ulsort,texte(langue,1)) 'Sortie', nompro
 283       write (ulsort,texte(langue,2)) codret
 284 c
 285       endif
 286 c
 287 #ifdef _DEBUG_HOMARD_
 288       write (ulsort,texte(langue,1)) 'Sortie', nompro
 289       call dmflsh (iaux)
 290 #endif
 291 c
 292       end