src/tool/ES_HOMARD/esecf0.F

   1       subroutine esecf0 ( idfmed, nomamd,
   2      >                    typenh, nbfent, numfam, nhenti,
   3      >                    tbiaux,
   4      >                    ulsort, langue, codret)
   5 c
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c  Entree-Sortie : ECriture des Familles d'une entite - 0
  27 c  -      -        --           -                       -
  28 c ______________________________________________________________________
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . idfmed . e   .   1    . identificateur du fichier MED              .
  32 c . nomamd . e   . char64 . nom du maillage MED voulu                  .
  33 c . typenh . e   .   1    . code des entites                           .
  34 c .        .     .        .  -1 : noeuds                               .
  35 c .        .     .        .   0 : mailles-points                       .
  36 c .        .     .        .   1 : aretes                               .
  37 c .        .     .        .   2 : triangles                            .
  38 c .        .     .        .   3 : tetraedres                           .
  39 c .        .     .        .   4 : quadrangles                          .
  40 c .        .     .        .   5 : pyramides                            .
  41 c .        .     .        .   6 : hexaedres                            .
  42 c .        .     .        .   7 : pentaedres                           .
  43 c . nbfent . e   .   1    . nombre de familles d'entites (cf. nbfami)  .
  44 c . numfam . es  .   1    . numerotation des familles                  .
  45 c . nhenti . e   . char*8 . objet decrivant l'entite                   .
  46 c . tbiaux .     .    *   . tableau tampon entier                      .
  47 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  48 c . langue . e   .    1   . langue des messages                        .
  49 c .        .     .        . 1 : francais, 2 : anglais                  .
  50 c . codret . es  .    1   . code de retour des modules                 .
  51 c .        .     .        . 0 : pas de probleme                        .
  52 c ______________________________________________________________________
  53 c
  54 c====
  55 c 0. declarations et dimensionnement
  56 c====
  57 c
  58 c 0.1. ==> generalites
  59 c
  60       implicit none
  61       save
  62 c
  63       character*6 nompro
  64       parameter ( nompro = 'ESECF0' )
  65 c
  66 #include "nblang.h"
  67 #include "consts.h"
  68 c
  69 c 0.2. ==> communs
  70 c
  71 #include "envex1.h"
  72 c
  73 #include "gmenti.h"
  74 c
  75 #include "enti01.h"
  76 #include "impr02.h"
  77 c
  78 c 0.3. ==> arguments
  79 c
  80       integer*8 idfmed
  81       integer typenh, nbfent, numfam
  82       integer tbiaux(*)
  83 c
  84       character*64 nomamd
  85       character*8 nhenti
  86 c
  87       integer ulsort, langue, codret
  88 c
  89 c 0.4. ==> variables locales
  90 c
  91 #include "meddc0.h"
  92 c
  93       integer nbgrox
  94       parameter (nbgrox = 10 )
  95 c
  96       integer iaux, jaux, kaux, laux
  97       integer cptr, kfin, reste
  98       integer codre1
  99       integer adcofa
 100       integer adcoen
 101       integer nbcode, ngro
 102 c
 103       character*8 saux08
 104       character*80 nomgro(nbgrox)
 105       character*64 saux64
 106 c
 107       integer nbmess
 108       parameter ( nbmess = 150 )
 109       character*80 texte(nblang,nbmess)
 110 c ______________________________________________________________________
 111 c
 112 c====
 113 c 1. messages
 114 c====
 115 c
 116 #include "impr01.h"
 117 c
 118 #ifdef _DEBUG_HOMARD_
 119       write (ulsort,texte(langue,1)) 'Entree', nompro
 120       call dmflsh (iaux)
 121 #endif
 122 c
 123       texte(1,4) = '(''. Ecriture des'',i4,'' familles des '',a)'
 124       texte(1,5) = '(''... Ecriture de la'',i4,''-ieme famille'')'
 125       texte(1,6) = '(''Probleme de dimensionnement de nomgro.'')'
 126 c
 127       texte(2,4) = '(''. Writings of'',i4,'' families for '',a)'
 128       texte(2,5) = '(''... Writings of the'',i4,''-th family'')'
 129       texte(2,6) = '(''Error in size of array nomgro.'')'
 130 c
 131 #include "impr03.h"
 132 c
 133 #include "esimpr.h"
 134 c
 135 #ifdef _DEBUG_HOMARD_
 136       write (ulsort,texte(langue,4)) nbfent, mess14(langue,3,typenh)
 137       call gmprsx ( nompro, nhenti//'.Famille' )
 138       call gmprsx ( nompro, nhenti//'.Famille.Codes' )
 139 cc      call gmprsx ( nompro, nhenti//'.Famille.Groupe' )
 140 #endif
 141 c
 142 c====
 143 c 2. Gestion de la memoire
 144 c====
 145 c 2.1. ==> Determination des adresses
 146 c 2.1.1. ==> pour les noeuds
 147 c
 148       if ( typenh.lt.0 ) then
 149 c
 150 #ifdef _DEBUG_HOMARD_
 151         write (ulsort,texte(langue,3)) 'UTAD01', nompro
 152 #endif
 153         iaux = 7
 154         call utad01 (   iaux, nhenti,
 155      >                  jaux,
 156      >                  jaux, adcofa,   jaux,
 157      >                  jaux,   jaux,   jaux,   jaux,
 158      >                ulsort, langue, codret )
 159 c
 160 c 2.1.2. ==> pour les mailles
 161 c
 162       else
 163 c
 164 #ifdef _DEBUG_HOMARD_
 165         write (ulsort,texte(langue,3)) 'UTAD02', nompro
 166 #endif
 167         iaux = 37
 168         call utad02 (   iaux, nhenti,
 169      >                  jaux,   jaux,   jaux,   jaux,
 170      >                  jaux, adcofa,   jaux,
 171      >                  jaux,   jaux,   jaux,
 172      >                  jaux,   jaux,   jaux,
 173      >                ulsort, langue, codret )
 174 c
 175       endif
 176 c
 177 c 2.2. ==> Nombre de codes definissant les familles
 178 c
 179       if ( codret.eq.0 ) then
 180 c
 181       call gmliat ( nhenti//'.Famille', 2, nbcode, codre1 )
 182 c
 183       codret = max ( codret,
 184      >               abs(codre1) )
 185 c
 186 #ifdef _DEBUG_HOMARD_
 187       write(ulsort,90002) 'nbcode', nbcode
 188 #endif
 189 c
 190       endif
 191 c
 192 c====
 193 c 3. Ecritures
 194 c====
 195 #ifdef _DEBUG_HOMARD_
 196       write (ulsort,*) '3. Ecritures ; codret = ', codret
 197 #endif
 198 c
 199       if ( codret.eq.0 ) then
 200 c
 201       adcoen = adcofa - 1
 202       do 31 , iaux = 1 , nbfent
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,texte(langue,5)) iaux
 206       call gmprsx ( nompro, nhenti//'.Famille.Codes' )
 207 #endif
 208 c
 209         if ( codret.eq.0 ) then
 210 c
 211 c       fabrication du numero de la famille a ecrire
 212 c
 213         if ( typenh.lt.0 ) then
 214           numfam = numfam + 1
 215         else
 216           numfam = numfam - 1
 217         endif
 218 c
 219 c       fabrication du nom de la famille a ecrire
 220 c
 221         call utench ( numfam, '_', jaux, saux08,
 222      >                ulsort, langue, codret )
 223 c
 224         saux64 = blan64
 225         saux64(1:2) = suffix(3,typenh)(1:2)
 226         saux64( 3:10) = saux08
 227 c
 228 c       les valeurs entieres a memoriser
 229 c       . le numero de la famille
 230         tbiaux(1) = iaux
 231 c
 232 c       . les nctfen codes definissant les familles
 233         do 311 , jaux = 1, nbcode
 234           tbiaux(jaux+1) = imem(adcoen+jaux)
 235   311   continue
 236         adcoen = adcoen + nbcode
 237 c
 238         endif
 239 c
 240 c       fabrication d'un nom de groupe contenant ces valeurs
 241 c       . Les 8 1ers caracteres sont 'Attribut' obligatoirement, pour
 242 c         se reperer dans le dump
 243 c       . Les caracteres de 2 a nbcode+1 sont les nbcode codes
 244 c         convertis en chaine
 245 c        Remarque : cela suppose qu'il n'y a pas plus de 9 codes
 246 c        et que chaque code est inferieur a 10**8
 247 c
 248 c       nombre de paquets
 249 c
 250         if ( codret.eq.0 ) then
 251 c
 252         reste = mod(nbcode+1,9)
 253         ngro = (nbcode+1-reste)/9
 254         if ( reste.gt.0 ) then
 255           ngro = ngro + 1
 256         endif
 257         if ( ngro.gt.nbgrox ) then
 258           codret = 31
 259         endif
 260 cgn        write(ulsort,*) 'Famille : ', saux64
 261 cgn        write(ulsort,90002) 'nbcode  ', nbcode
 262 cgn        write(ulsort,90002) 'reste ', reste
 263 cgn        write(ulsort,90002) 'ngro  ', ngro
 264 c
 265         endif
 266 c
 267         if ( codret.eq.0 ) then
 268 c
 269         cptr = 0
 270         do 312 , jaux = 1, ngro
 271 c
 272           nomgro(jaux) = blan80
 273 c                      12345678
 274           nomgro(jaux)(1:8) = 'Attribut'
 275           if ( jaux.lt.ngro .or. reste.eq.0 ) then
 276             kfin = 9
 277           else
 278             kfin = reste
 279           endif
 280           do 3121 , kaux = 1, kfin
 281             cptr = cptr + 1
 282             call utench ( tbiaux(cptr), 'd', laux, saux08,
 283      >                    ulsort, langue, codret )
 284             nomgro(jaux)(8*kaux+1:8*(kaux+1)) = saux08
 285  3121     continue
 286   312   continue
 287 c
 288         endif
 289 c
 290         if ( codret.eq.0 ) then
 291 c
 292 #ifdef _DEBUG_HOMARD_
 293       write(ulsort,*) 'Famille : ', saux64
 294       write(ulsort,90002) 'nbcode', nbcode
 295       if ( nbcode.gt.0 ) then
 296         write(ulsort,90002) '.', (tbiaux(jaux),jaux=1,nbcode+1)
 297       endif
 298       write(ulsort,90002) 'ngro', ngro
 299       write(ulsort,*) nomgro
 300 #endif
 301 c
 302 #ifdef _DEBUG_HOMARD_
 303       write (ulsort,texte(langue,3)) 'MFACRE', nompro
 304 #endif
 305         call mfacre ( idfmed, nomamd, saux64, numfam,
 306      >                ngro, nomgro, codret )
 307 c
 308         if ( codret.ne.0 ) then
 309           write(ulsort,texte(langue,78)) 'mfacre', codret
 310         endif
 311 c
 312         endif
 313 c
 314    31 continue
 315 c
 316       endif
 317 c
 318 c====
 319 c 4. la fin
 320 c====
 321 c
 322       if ( codret.ne.0 ) then
 323 c
 324 #include "envex2.h"
 325 c
 326       write (ulsort,texte(langue,1)) 'Sortie', nompro
 327       write (ulsort,texte(langue,2)) codret
 328       if ( codret.eq.31 ) then
 329         write(ulsort,90002) 'ngro  ', ngro
 330         write(ulsort,90002) 'nbgrox', nbgrox
 331         write (ulsort,texte(langue,6))
 332       endif
 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