src/tool/ES_MED/esemm0.F

   1       subroutine esemm0 ( idfmed, nomamd,
   2      >                      sdim,   mdim, descri,
   3      >                     nbpqt, inftbl,
   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 d'un Maillage au format MED - phase 0
  27 c  -      -        -             -                  -           -
  28 c ______________________________________________________________________
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . idfmed . e   .   1    . identificateur du fichier de               .
  32 c .        .     .        . maillage de sortie                         .
  33 c . nomamd . e   . char64 . nom du maillage MED                        .
  34 c . sdim   . e   .   1    . dimension de l'espace                      .
  35 c . mdim   . e   .   1    . dimension du maillage                      .
  36 c . inftbl . e   .nbpqt*10. tables en caracteres des infos generales   .
  37 c .        .     .        . regroupees par paquets de 80 caracteres    .
  38 c .        .     .        . pour gerer la conversion en pseudo-groupe  .
  39 c .        .     .        . paquet 1 : 1 : 'NomCo'                       .
  40 c .        .     .        .            2/3, 4/5, 6/7 : nom coordonnees .
  41 c .        .     .        .            8 : nom du repere utilise       .
  42 c .        .     .        . paquet 2 : 1 : 'UniteCo'                     .
  43 c .        .     .        .            2/3, 4/5, 6/7 : unite coord.    .
  44 c .        .     .        . paquet 3 : titre (limite a 80 caracteres)  .
  45 c .        .     .        . paquet 4 : 1 : 'NOMAMD'                    .
  46 c .        .     .        .            2-7 :  nom du maillage          .
  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 = 'ESEMM0' )
  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 c 0.3. ==> arguments
  74 c
  75       integer*8 idfmed
  76       integer sdim, mdim
  77       integer nbpqt
  78 c
  79       character*8 inftbl(10*nbpqt)
  80 c
  81       character*64 nomamd
  82       character*200 descri
  83 c
  84       integer ulsort, langue, codret
  85 c
  86 c 0.4. ==> variables locales
  87 c
  88 #include "meddc0.h"
  89 c
  90       integer iaux, jaux, kaux
  91       integer typrep
  92       integer stype
  93 c
  94       character*16 nomaxe(3), uniaxe(3)
  95       character*16 dtunit
  96 c
  97       integer nbmess
  98       parameter ( nbmess = 150 )
  99       character*80 texte(nblang,nbmess)
 100 c ______________________________________________________________________
 101 c
 102 c====
 103 c 1. initialisations
 104 c====
 105 c
 106 #include "impr01.h"
 107 c
 108 #ifdef _DEBUG_HOMARD_
 109       write (ulsort,texte(langue,1)) 'Entree', nompro
 110       call dmflsh (iaux)
 111 #endif
 112 c
 113       texte(1,4) = '(''Ecriture complete.'')'
 114       texte(1,5) = '(''Ecriture uniquement de la renumerotation.'')'
 115 c
 116       texte(2,4) = '(''Full writings.'')'
 117       texte(2,5) = '(''Writings of numbering only.'')'
 118 c
 119 #include "impr03.h"
 120 c
 121 #include "esimpr.h"
 122 c
 123       codret = 0
 124 c
 125 c====
 126 c 2. restauration des noms et unites des axes
 127 c====
 128 c
 129       do 21 , iaux = 1, nbpqt
 130 c
 131         jaux = 10*(iaux-1) + 1
 132 cgn        write (ulsort,90064) jaux, '%'//inftbl(jaux)//'%'
 133 c
 134 c 2.1. Repere et noms des coordonnees
 135 c
 136         if ( inftbl(jaux).eq.'NomCo   ' ) then
 137 c
 138           read ( inftbl(jaux+9), '(i8)' ) typrep
 139 cgn          write (ulsort,90002)'typrep',typrep
 140           do 211 , kaux = 1 , sdim
 141             nomaxe(kaux) = inftbl(jaux+2*kaux-1)//inftbl(jaux+2*kaux)
 142 cgn            write (ulsort,90064) kaux, '%'//nomaxe(kaux)//'%'
 143   211     continue
 144 c
 145 c 2.2. Unites des coordonnees
 146 c
 147         elseif ( inftbl(jaux).eq.'UniteCo ' ) then
 148 c
 149           do 212 , kaux = 1 , sdim
 150             uniaxe(kaux) = inftbl(jaux+2*kaux-1)//inftbl(jaux+2*kaux)
 151 cgn            write (ulsort,90064) kaux, '%'//uniaxe(kaux)//'%'
 152   212     continue
 153 c
 154         endif
 155 c
 156    21 continue
 157 c
 158 c====
 159 c 3. creation du maillage
 160 c====
 161 #ifdef _DEBUG_HOMARD_
 162       write (ulsort,*) '3. creation du maillage ; codret = ', codret
 163 #endif
 164 c
 165       if ( codret.eq.0 ) then
 166 c
 167 c  a TRAITER mettre dtunit dans inftbl
 168       dtunit = blan16
 169       stype = edsodi
 170 #ifdef _DEBUG_HOMARD_
 171       write (ulsort,90002) 'idfmed', idfmed
 172       write (ulsort,90003) 'nomamd', nomamd
 173       write (ulsort,90002) 'len(nomamd)', len(nomamd)
 174       write (ulsort,90002) 'sdim  ', sdim
 175       write (ulsort,90002) 'mdim  ', mdim
 176       write (ulsort,90002) 'ednost', ednost
 177       write (ulsort,90003) 'descri', descri
 178       write (ulsort,90003) 'dtunit', dtunit
 179       write (ulsort,90002) 'stype ', stype
 180       write (ulsort,90002) 'typrep', typrep
 181       write (ulsort,90003) 'nomaxe', nomaxe
 182       write (ulsort,90003) 'uniaxe', uniaxe
 183 #endif
 184 c
 185 #ifdef _DEBUG_HOMARD_
 186       write (ulsort,texte(langue,3)) 'MMHCRE', nompro
 187 #endif
 188       call mmhcre ( idfmed, nomamd, sdim, mdim, ednost, descri,
 189      >              dtunit, stype, typrep, nomaxe, uniaxe, codret )
 190 c
 191       if ( codret.ne.0 ) then
 192         write(ulsort,texte(langue,78)) 'mmhcre', codret
 193       endif
 194 c
 195       endif
 196 c
 197 c====
 198 c 4. la fin
 199 c====
 200 c
 201       if ( codret.ne.0 ) then
 202 c
 203 #include "envex2.h"
 204 c
 205       write (ulsort,texte(langue,1)) 'Sortie', nompro
 206       write (ulsort,texte(langue,2)) codret
 207 c
 208       endif
 209 c
 210 #ifdef _DEBUG_HOMARD_
 211       write (ulsort,texte(langue,1)) 'Sortie', nompro
 212       call dmflsh (iaux)
 213 #endif
 214 c
 215       end