src/tool/ES_MED/eslsm3.F

   1       subroutine eslsm3 ( nbfonc, defonc,
   2      >                    nofonc,
   3      >                    ulsort, langue, codret )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c  Entree-Sortie - Lecture d'une Solution au format MED - phase 3
  25 c  -      -        -             -                  -           -
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . nbfonc . e   .   1    . nombre de fonctions                        .
  31 c . defonc . e   . nbinec*. description des fonctions en entier        .
  32 c .        .     . nbfonc . 1. type de support au sens MED             .
  33 c .        .     .        . 2. nombre de points de Gauss               .
  34 c .        .     .        . 3. nombre de valeurs                       .
  35 c .        .     .        . 4. nombre de valeurs du profil eventuel    .
  36 c .        .     .        . 5. nombre de supports associes             .
  37 c .        .     .        . 6. 1, si aux noeuds par elements           .
  38 c .        .     .        .    2, si aux points de Gauss, associe avec .
  39 c .        .     .        .       un champ aux noeuds par elements     .
  40 c .        .     .        .    3, si aux points de Gauss autonome      .
  41 c .        .     .        .    0, sinon                                .
  42 c .        .     .        . 7. nombre de tableaux de ce type           .
  43 c .        .     .        . 8. numero du tableau dans la fonction      .
  44 c .        .     .        . 9. numero de la fonction associee si champ .
  45 c .        .     .        .    aux noeuds par element ou points de Gaus.
  46 c .        .     .        . 10. numero HOMARD du champ associe         .
  47 c .        .     .        . 11. type interpolation                     .
  48 c .        .     .        .       0, si automatique                    .
  49 c .        .     .        .       1 si degre 1, 2 si degre 2,          .
  50 c .        .     .        .       3 si iso-P2                          .
  51 c .        .     .        . 12. type de champ edfl64/edin64            .
  52 c .        .     .        . 21-nbinec. type des supports associes      .
  53 c . nofonc . es  .3*nbfonc. description des fonctions en caracteres    .
  54 c .        .     .        . 1. nom de l'objet profil, blanc sinon      .
  55 c .        .     .        . 2. nom de l'objet fonction                 .
  56 c .        .     .        . 3. nom de l'objet localisation des points  .
  57 c .        .     .        . de Gauss, blanc sinon                      .
  58 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  59 c . langue . e   .    1   . langue des messages                        .
  60 c .        .     .        . 1 : francais, 2 : anglais                  .
  61 c . codret . es  .    1   . code de retour des modules                 .
  62 c .        .     .        . 0 : pas de probleme                        .
  63 c .        .     .        . 1 : probleme                               .
  64 c ______________________________________________________________________
  65 c
  66 c====
  67 c 0. declarations et dimensionnement
  68 c====
  69 c
  70 c 0.1. ==> generalites
  71 c
  72       implicit none
  73       save
  74 c
  75       character*6 nompro
  76       parameter ( nompro = 'ESLSM3' )
  77 c
  78 #include "nblang.h"
  79 #include "consts.h"
  80 #include "meddc0.h"
  81 c
  82 c 0.2. ==> communs
  83 c
  84 #include "envex1.h"
  85 c
  86 #include "esutil.h"
  87 #include "gmenti.h"
  88 #include "gmstri.h"
  89 c
  90 c 0.3. ==> arguments
  91 c
  92       integer nbfonc
  93       integer defonc(nbinec,*)
  94 c
  95       character*8 nofonc(3,*)
  96 c
  97       integer ulsort, langue, codret
  98 c
  99 c 0.4. ==> variables locales
 100 c
 101       integer iaux
 102       integer nrfonc
 103       integer typcha
 104       integer typgeo, ngauss, nbenmx, nbvapr, nbtyas
 105       integer carsup, nbtafo, typint
 106       integer advale, advalr, adobch, adprpg, adtyas
 107 c
 108       character*8 obfonc
 109 c
 110       integer nbmess
 111       parameter ( nbmess = 150 )
 112       character*80 texte(nblang,nbmess)
 113 c
 114 c 0.5. ==> initialisations
 115 c ______________________________________________________________________
 116 c
 117 c====
 118 c 1. initialisations
 119 c====
 120 c
 121 #include "impr01.h"
 122 c
 123 #ifdef _DEBUG_HOMARD_
 124       write (ulsort,texte(langue,1)) 'Entree', nompro
 125       call dmflsh (iaux)
 126 #endif
 127 c
 128 #include "esimpr.h"
 129 c
 130 c====
 131 c 2. creations des fonctions
 132 c====
 133 c
 134       do 20 , nrfonc = 1 , nbfonc
 135 c
 136         if ( codret.eq.0 ) then
 137 c
 138 #ifdef _DEBUG_HOMARD_
 139         write (ulsort,*) '============================================='
 140         write (ulsort,texte(langue,36)) nompro, nrfonc
 141         write (ulsort,texte(langue,64)) defonc(1,nrfonc)
 142         write (ulsort,texte(langue,69)) defonc(12,nrfonc)
 143         write (ulsort,texte(langue,64)) defonc(1,nrfonc)
 144         write (ulsort,texte(langue,57)) defonc(2,nrfonc)
 145         write (ulsort,texte(langue,58)) defonc(3,nrfonc)
 146         write (ulsort,texte(langue,62)) defonc(4,nrfonc)
 147         do 229 , iaux = 1, defonc(5,nrfonc)
 148           write (ulsort,texte(langue,60)) defonc(20+iaux,nrfonc)
 149   229   continue
 150         write (ulsort,texte(langue,65+defonc(6,nrfonc)))
 151         write (ulsort,texte(langue,111)) defonc(7,nrfonc)
 152         if ( defonc(11,nrfonc).ge.0 .and. defonc(11,nrfonc).le.3 ) then
 153           write (ulsort,texte(langue,100+defonc(11,nrfonc)))
 154         else
 155           write (ulsort,texte(langue,104))
 156         endif
 157         write (ulsort,texte(langue,61)) nofonc(1,nrfonc)
 158         write (ulsort,*) 'numero tableau : ',defonc(9,nrfonc)
 159         if ( defonc(2,nrfonc).eq.ednopg ) then
 160           write (ulsort,*) 'Allocation a ',
 161      >    defonc(3,nrfonc)*defonc(7,nrfonc), ' = ',
 162      >    defonc(3,nrfonc), '*', defonc(7,nrfonc)
 163         else
 164           write (ulsort,*) 'Allocation a ',
 165      >    defonc(3,nrfonc)*defonc(7,nrfonc)*defonc(2,nrfonc), ' = ',
 166      >    defonc(3,nrfonc), '*', defonc(7,nrfonc), '*', defonc(2,nrfonc)
 167         endif
 168 #endif
 169 c
 170         typcha = defonc(12,nrfonc)
 171 #ifdef _DEBUG_HOMARD_
 172       write (ulsort,texte(langue,3)) 'UTALFO', nompro
 173 #endif
 174         call utalfo ( obfonc, typcha,
 175      >                defonc(1,nrfonc), defonc(2,nrfonc),
 176      >                defonc(3,nrfonc), defonc(4,nrfonc),
 177      >                defonc(5,nrfonc), defonc(6,nrfonc),
 178      >                defonc(7,nrfonc), defonc(11,nrfonc),
 179      >                advale, advalr, adobch, adprpg, adtyas,
 180      >                ulsort, langue, codret )
 181 c
 182         endif
 183 c
 184 #ifdef _DEBUG_HOMARD_
 185         call gmprsx (nompro, obfonc )
 186 #endif
 187 c
 188         if ( codret.eq.0 ) then
 189 c
 190         do 21 , iaux = 1, defonc(5,nrfonc)
 191           imem(adtyas+iaux-1) = defonc(20+iaux,nrfonc)
 192    21   continue
 193         nofonc(2,nrfonc) = obfonc
 194 c
 195         endif
 196 c
 197    20 continue
 198 c
 199 c====
 200 c 3. memorisation des fonctions associees
 201 c====
 202 c
 203       do 30 , nrfonc = 1 , nbfonc
 204 c
 205         iaux = defonc(9,nrfonc)
 206 c
 207         if ( iaux.ne.0 ) then
 208 c
 209 c 3.1. ==> caracteristiques de la fonction courante
 210 c
 211           if ( codret.eq.0 ) then
 212 c
 213           obfonc = nofonc(2,nrfonc)
 214 #ifdef _DEBUG_HOMARD_
 215       write (ulsort,texte(langue,3)) 'UTCAFO', nompro
 216 #endif
 217           call utcafo ( obfonc,
 218      >                  typcha,
 219      >                  typgeo, ngauss, nbenmx, nbvapr, nbtyas,
 220      >                  carsup, nbtafo, typint,
 221      >                  advale, advalr, adobch, adprpg, adtyas,
 222      >                  ulsort, langue, codret )
 223           endif
 224 c
 225 c 3.2. ==> memorisation du nom de la fonction associee
 226 c
 227           if ( codret.eq.0 ) then
 228 c
 229           smem(adprpg+2) = nofonc(2,iaux)
 230 c
 231           endif
 232 c
 233         endif
 234 c
 235    30 continue
 236 c
 237 c====
 238 c 4. la fin
 239 c====
 240 c
 241       if ( codret.ne.0 ) then
 242 c
 243 #include "envex2.h"
 244 c
 245       write (ulsort,texte(langue,1)) 'Sortie', nompro
 246       write (ulsort,texte(langue,2)) codret
 247 c
 248       endif
 249 c
 250 #ifdef _DEBUG_HOMARD_
 251       write (ulsort,texte(langue,1)) 'Sortie', nompro
 252       call dmflsh (iaux)
 253 #endif
 254 c
 255       end
 256