src/tool/ES_HOMARD/esemho.F

   1       subroutine esemho ( typobs, nrosec, nretap, nrsset,
   2      >                    optecr,
   3      >                    suifro, nocdfr,
   4      >                    ulsort, langue, codret)
   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 du Maillage HOmard
  26 c  -      -        -           -        --
  27 c ______________________________________________________________________
  28 c   tant que rien n'a change, on a archive des informations dans
  29 c    les sous-tableaux des branches InfoSupE et InfoSupS
  30 c    Entiers de InfoSupE :
  31 c       Tab1 : communs entiers
  32 c       Tab2 : type des elements
  33 c       Tab3, Tab4, Tab5 et Tab6 sont reserves au transfert
  34 c       d'informations du maillage au format MED.
  35 c       Tab10 : activation des groupes des frontieres a suivre
  36 c    Chaines de InfoSupS :
  37 c       Tab3, Tab4 et Tab5 sont reserves au transfert
  38 c       d'informations du maillage au format MED.
  39 c       Tab10 : nom des groupes des frontieres a suivre
  40 c ______________________________________________________________________
  41 c .  nom   . e/s . taille .           description                      .
  42 c .____________________________________________________________________.
  43 c . typobs . e   . char*8 . mot-cle correspondant a l'objet a ecrire   .
  44 c . nrosec . e   .   1    . numero de section pour les mesures de temps.
  45 c . nretap . e   .   1    . numero d'etape                             .
  46 c . nrsset . e   .   1    . numero de sous-etape                       .
  47 c . optecr . e   .   1    . option d'ecriture                          .
  48 c .        .     .        . >0 : on ecrit la frontiere discrete        .
  49 c .        .     .        . <0 : on n'ecrit pas la frontiere discrete  .
  50 c . suifro . e   .   1    . 1 : pas de suivi de frontiere              .
  51 c .        .     .        . 2x : frontiere discrete                    .
  52 c .        .     .        . 3x : frontiere analytique                  .
  53 c .        .     .        . 5x : frontiere cao                         .
  54 c . nocdfr . e   . char8  . nom de l'objet description de la frontiere .
  55 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  56 c . langue . e   .    1   . langue des messages                        .
  57 c .        .     .        . 1 : francais, 2 : anglais                  .
  58 c . codret . es  .    1   . code de retour des modules                 .
  59 c .        .     .        . 0 : pas de probleme                        .
  60 c ______________________________________________________________________
  61 c
  62 c====
  63 c 0. declarations et dimensionnement
  64 c====
  65 c
  66 c 0.1. ==> generalites
  67 c
  68       implicit none
  69       save
  70 c
  71       character*6 nompro
  72       parameter ( nompro = 'ESEMHO' )
  73 c
  74 #include "nblang.h"
  75 c
  76 c 0.2. ==> communs
  77 c
  78 #include "envex1.h"
  79 c
  80 #include "envca1.h"
  81 c
  82 c 0.3. ==> arguments
  83 c
  84       character*8 typobs
  85 c
  86       integer nrosec, nretap, nrsset
  87       integer optecr
  88       integer suifro
  89 c
  90       character*8 nocdfr
  91 c
  92       integer ulsort, langue, codret
  93 c
  94 c 0.4. ==> variables locales
  95 c
  96       integer codava
  97 c
  98       integer lnomfi
  99 c
 100       integer iaux, jaux
 101 c
 102       character*8 nomail
 103       character*8 norenu
 104       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 105       character*8 nhtetr, nhhexa, nhpyra, nhpent
 106       character*8 nhelig
 107       character*8 nhvois, nhsupe, nhsups
 108 c
 109       character*6 saux
 110       character*200 nomfic
 111 c
 112       integer nbmess
 113       parameter ( nbmess = 10 )
 114       character*80 texte(nblang,nbmess)
 115 c ______________________________________________________________________
 116 c
 117 c====
 118 c 1. les initialisations
 119 c====
 120 c
 121       codava = codret
 122 c
 123 c=======================================================================
 124       if ( codava.eq.0 ) then
 125 c=======================================================================
 126 c
 127 c 1.1. ==> le debut des mesures de temps
 128 c
 129       if ( nrosec.gt.0 ) then
 130         call gtdems (nrosec)
 131       endif
 132 c
 133 c 1.2. ==> les messages
 134 c
 135 #include "impr01.h"
 136 c
 137 #ifdef _DEBUG_HOMARD_
 138       write (ulsort,texte(langue,1)) 'Entree', nompro
 139       call dmflsh (iaux)
 140 #endif
 141 c
 142       texte(1,4) = '(//,a6,'' SAUVEGARDE DU MAILLAGE HOMARD'')'
 143       texte(1,5) = '(36(''=''),/)'
 144       texte(1,6) =
 145      > '(/,5x,''Ecriture du maillage '',a,'' sur le fichier'')'
 146       texte(1,7) = '(/,1x,''Mot-cle : '',a8)'
 147 c
 148       texte(2,4) = '(//,a6,'' RECORDING OF HOMARD MESH'')'
 149       texte(2,5) = '(31(''=''),/)'
 150       texte(2,6) = '(/,5x,''Writing of mesh '',a,'' on file'')'
 151       texte(2,7) = '(/,1x,''Keyword : '',a8)'
 152 c
 153 #include "impr03.h"
 154 c
 155 c 1.3. ==> le titre
 156 c
 157       call utcvne ( nretap, nrsset, saux, iaux, codret )
 158 c
 159       write (ulsort,texte(langue,4)) saux
 160       write (ulsort,texte(langue,5))
 161 c
 162 c====
 163 c 2. nom du maillage et du fichier
 164 c====
 165 c
 166       iaux = 0
 167       jaux = 1
 168       call utfino ( typobs, iaux, nomfic, lnomfi,
 169      >              jaux,
 170      >              ulsort, langue, codret )
 171 c
 172       if ( codret.eq.0 ) then
 173 c
 174 #ifdef _DEBUG_HOMARD_
 175       write (ulsort,texte(langue,3)) 'UTOSNO', nompro
 176 #endif
 177       iaux = 0
 178       call utosno ( typobs, nomail, iaux, ulsort, langue, codret )
 179 c
 180       endif
 181 c
 182       if ( codret.eq.0 ) then
 183 c
 184       write (ulsort,texte(langue,6)) nomail
 185       write (ulsort,*) '    '//nomfic(1:lnomfi)
 186 c
 187       endif
 188 c
 189 c====
 190 c 3. Branche des informations entieres
 191 c====
 192 c
 193 #ifdef _DEBUG_HOMARD_
 194       write (ulsort,90002) '3. Branche des entiers ; codret', codret
 195 #endif
 196 c
 197       if ( codret.eq.0 ) then
 198 c
 199 #ifdef _DEBUG_HOMARD_
 200       write (ulsort,texte(langue,3)) 'ESEMH0', nompro
 201 #endif
 202       call esemh0 ( nomail,
 203      >              ulsort, langue, codret)
 204 c
 205       endif
 206 c
 207 c====
 208 c 4. recuperation des donnees du maillage d'entree
 209 c====
 210 #ifdef _DEBUG_HOMARD_
 211       write (ulsort,90002) '4. recuperation entree ; codret', codret
 212 #endif
 213 c
 214       if ( codret.eq.0 ) then
 215 c
 216 #ifdef _DEBUG_HOMARD_
 217       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 218 #endif
 219       call utnomh ( nomail,
 220      >                sdim,   mdim,
 221      >               degre, maconf, homolo, hierar,
 222      >              rafdef, nbmane, typcca, typsfr, maextr,
 223      >              mailet,
 224      >              norenu,
 225      >              nhnoeu, nhmapo, nharet,
 226      >              nhtria, nhquad,
 227      >              nhtetr, nhhexa, nhpyra, nhpent,
 228      >              nhelig,
 229      >              nhvois, nhsupe, nhsups,
 230      >              ulsort, langue, codret)
 231 c
 232       endif
 233 #ifdef _DEBUG_HOMARD_
 234       write (ulsort,90002) 'sdim', sdim
 235       write (ulsort,90002) 'mdim', mdim
 236 #endif
 237 c      call gmprsx(nompro, nhelig)
 238 c      call gmprsx(nompro, nhelig//'.Numero')
 239 c      call gmprsx(nompro, nhelig//'.ConnNoeu')
 240 c      call gmprsx(nompro, nhelig//'.Type')
 241 c      call gmprsx(nompro, nhelig//'.FamilMED')
 242 c
 243 c====
 244 c 5. appel du programme utilitaire
 245 c====
 246 #ifdef _DEBUG_HOMARD_
 247       write (ulsort,90002) '5. appel de esemh1 ; codret', codret
 248 #endif
 249 c
 250       if ( codret.eq.0 ) then
 251 c
 252 #ifdef _DEBUG_HOMARD_
 253       write (ulsort,texte(langue,3)) 'ESEMH1', nompro
 254 #endif
 255       call esemh1 ( nomail, nomfic, lnomfi,
 256      >              optecr,
 257      >              nhnoeu, nhmapo, nharet, nhtria, nhquad,
 258      >              nhtetr, nhhexa, nhpyra, nhpent,
 259      >              nhelig,
 260      >              nhsups,
 261      >              suifro, nocdfr,
 262      >              ulsort, langue, codret )
 263 c
 264       endif
 265 c
 266 c====
 267 c 6. la fin
 268 c====
 269 c
 270 #ifdef _DEBUG_HOMARD_
 271       write (ulsort,90002) '6. La fin ; codret', codret
 272 #endif
 273 c
 274 c 6.1. ==> message si erreur
 275 c
 276       if ( codret.ne.0 ) then
 277 c
 278 #include "envex2.h"
 279 c
 280       write (ulsort,texte(langue,1)) 'Sortie', nompro
 281       write (ulsort,texte(langue,2)) codret
 282       write (ulsort,texte(langue,7)) typobs
 283       codret = 7
 284 c
 285       endif
 286 c
 287 c 6.2. ==> fin des mesures de temps de la section
 288 c
 289       if ( nrosec.gt.0 ) then
 290         call gtfims (nrosec)
 291       endif
 292 c
 293 #ifdef _DEBUG_HOMARD_
 294       write (ulsort,texte(langue,1)) 'Sortie', nompro
 295       call dmflsh (iaux)
 296 #endif
 297 c=======================================================================
 298       endif
 299 c=======================================================================
 300 c
 301       end