src/tool/ES_MED/eslch3.F

   1       subroutine eslch3 ( nrocha, nomcha, nbcomp, nbtvch,
   2      >                    caraen, caraca,
   3      >                    nbfonc, defonc, nofonc,
   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 - Lecture d'un CHamp au format MED - phase 3
  26 c  -      -        -            --                          -
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nrocha . e   .    1   . numero du champ dans le rangement HOMARD   .
  32 c . nomcha . e   . char64 . nom du champ                               .
  33 c . nbcomp . e   .   1    . nombre de composantes                      .
  34 c . nbtvch . e   .   1    . nombre de tableaux associes a ce champ     .
  35 c . caraen . e   . nbinec*. caracteristiques entieres des tableaux du  .
  36 c .        .     . nbtvch . champ en cours d'examen                    .
  37 c .        .     .        . 1. type de support au sens MED             .
  38 c .        .     .        .  -1, si on prend tous les supports         .
  39 c .        .     .        . 2. numero du pas de temps                  .
  40 c .        .     .        . 3. numero d'ordre                          .
  41 c .        .     .        . 4. nombre de points de Gauss               .
  42 c .        .     .        . 5. nombre d'entites support                .
  43 c .        .     .        . 6. nombre de valeurs du profil eventuel    .
  44 c .        .     .        . 7. nombre de supports associes             .
  45 c .        .     .        . 8. 1, si aux noeuds par elements           .
  46 c .        .     .        .    2, si aux points de Gauss, associe avec .
  47 c .        .     .        .       un champ aux noeuds par elements     .
  48 c .        .     .        .    3, si aux points de Gauss autonome      .
  49 c .        .     .        .    0, sinon                                .
  50 c .        .     .        . 9. numero du 1er tableau dans la fonction  .
  51 c .        .     .        . 10. si champ elga, numero du champ elno    .
  52 c .        .     .        .     si champ elno, numero du champ elga si .
  53 c .        .     .        .     il existe, sinon -1                    .
  54 c .        .     .        . 11. type interpolation                     .
  55 c .        .     .        .       0, si automatique                    .
  56 c .        .     .        .       1 si degre 1, 2 si degre 2,          .
  57 c .        .     .        .       3 si iso-P2                          .
  58 c .        .     .        . 12. type de champ edfl64/edin64            .
  59 c .        .     .        . 21-nbinec. type des supports associes      .
  60 c . caraca . e   . nbincc*. caracteristiques caracteres des tableaux   .
  61 c .        .     . nbtvch . du champ en cours d'examen                 .
  62 c .        .     .        . 1. nom de l'objet fonction                 .
  63 c .        .     .        . 2. nom de l'objet profil, blanc sinon      .
  64 c .        .     .        . 3. nom de l'objet localisation des points  .
  65 c .        .     .        . de Gauss, blanc sinon                      .
  66 c . nbfonc . es  .   1    . nombre de fonctions classees               .
  67 c . defonc . es  . nbinec*. description des fonctions en entier        .
  68 c .        .     . nbfonc . 1. type de support au sens MED             .
  69 c .        .     .        . 2. nombre de points de Gauss               .
  70 c .        .     .        . 3. nombre de valeurs                       .
  71 c .        .     .        . 4. nombre de valeurs du profil eventuel    .
  72 c .        .     .        . 5. nombre de supports associes             .
  73 c .        .     .        . 6. 1, si aux noeuds par elements           .
  74 c .        .     .        .    2, si aux points de Gauss, associe avec .
  75 c .        .     .        .       un champ aux noeuds par elements     .
  76 c .        .     .        .    3, si aux points de Gauss autonome      .
  77 c .        .     .        .    0, sinon                                .
  78 c .        .     .        . 7. nombre de tableaux de ce type           .
  79 c .        .     .        . 8. numero du tableau dans la fonction      .
  80 c .        .     .        . 9. numero de la fonction associee si champ .
  81 c .        .     .        .    aux noeuds par element ou points de Gaus.
  82 c .        .     .        . 10. numero HOMARD du champ associe         .
  83 c .        .     .        . 11. type interpolation                     .
  84 c .        .     .        .       0, si automatique                    .
  85 c .        .     .        .       1 si degre 1, 2 si degre 2,          .
  86 c .        .     .        .       3 si iso-P2                          .
  87 c .        .     .        . 12. type de champ edfl64/edin64            .
  88 c .        .     .        . 21-20+(7). type des supports associes      .
  89 c . nofonc .   s .3*nbfonc. description des fonctions en caracteres    .
  90 c .        .     .        . 1. nom de l'objet profil, blanc sinon      .
  91 c .        .     .        . 2. nom de l'objet fonction                 .
  92 c .        .     .        . 3. nom de l'objet localisation des points  .
  93 c .        .     .        . de Gauss, blanc sinon                      .
  94 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  95 c . langue . e   .    1   . langue des messages                        .
  96 c .        .     .        . 1 : francais, 2 : anglais                  .
  97 c . codret . es  .    1   . code de retour des modules                 .
  98 c .        .     .        . 0 : pas de probleme                        .
  99 c .        .     .        . 1 : probleme                               .
 100 c ______________________________________________________________________
 101 c
 102 c====
 103 c 0. declarations et dimensionnement
 104 c====
 105 c
 106 c 0.1. ==> generalites
 107 c
 108       implicit none
 109       save
 110 c
 111       character*6 nompro
 112       parameter ( nompro = 'ESLCH3' )
 113 c
 114 #include "nblang.h"
 115 #include "consts.h"
 116 c
 117 c 0.2. ==> communs
 118 c
 119 #include "esutil.h"
 120 #include "envex1.h"
 121 #include "meddc0.h"
 122 c
 123 c 0.3. ==> arguments
 124 c
 125       integer nrocha
 126       integer nbcomp, nbtvch
 127       integer nbfonc
 128       integer caraen(nbinec,nbtvch)
 129       integer defonc(nbinec,*)
 130 c
 131       character*8 caraca(nbincc,nbtvch)
 132       character*8 nofonc(3,*)
 133       character*64 nomcha
 134 c
 135       integer ulsort, langue, codret
 136 c
 137 c 0.4. ==> variables locales
 138 c
 139       integer iaux
 140       integer typgeo
 141       integer nrotv, nrfonc
 142       integer ngauss, nbensu, nbvapr, nbtyas, carsup, typint, typcha
 143 c
 144       logical trouve
 145 c
 146       character*8 obprof, oblopg
 147 c
 148       integer nbmess
 149       parameter ( nbmess = 150 )
 150       character*80 texte(nblang,nbmess)
 151 c
 152 c 0.5. ==> initialisations
 153 c ______________________________________________________________________
 154 c
 155 c====
 156 c 1. initialisations
 157 c====
 158 c
 159 #include "impr01.h"
 160 c
 161 #ifdef _DEBUG_HOMARD_
 162       write (ulsort,texte(langue,1)) 'Entree', nompro
 163       call dmflsh (iaux)
 164 #endif
 165 c
 166 #include "esimpr.h"
 167 c
 168       texte(1,4) = '(/,''Nom du champ : '',a)'
 169       texte(1,5) = '(''Numero du champ   :'',i5)'
 170       texte(1,6) = '(''Numero du tableau :'',i5)'
 171 c
 172       texte(2,4) = '(/,''Field Name : '',a)'
 173       texte(2,5) = '(''Field #'',i5)'
 174       texte(2,6) = '(''Array #'',i5)'
 175 c
 176 #include "impr03.h"
 177 c
 178 #ifdef _DEBUG_HOMARD_
 179       write (ulsort,texte(langue,4)) nomcha
 180       write (ulsort,texte(langue,5)) nrocha
 181       write (ulsort,90002) 'nbtvch', nbtvch
 182       write (ulsort,90002) 'nbcomp', nbcomp
 183 #endif
 184 c
 185 c====
 186 c 2. on parcourt tous les tableaux de ce champ
 187 c====
 188 c
 189       codret = 0
 190 c
 191       do 21 , nrotv = 1 , nbtvch
 192 c
 193 #ifdef _DEBUG_HOMARD_
 194       write (ulsort,texte(langue,6)) nrotv
 195 #endif
 196 cgn      write (ulsort,*)(caraen(nrfonc,nrotv), nrfonc = 1 , nbinec)
 197 c
 198 c 2.1. ==> caracteristiques du tableau courant
 199 c
 200         typgeo = caraen(1,nrotv)
 201         ngauss = caraen(4,nrotv)
 202         nbensu = caraen(5,nrotv)
 203         nbvapr = caraen(6,nrotv)
 204         nbtyas = caraen(7,nrotv)
 205         carsup = caraen(8,nrotv)
 206         typint = caraen(11,nrotv)
 207         typcha = caraen(12,nrotv)
 208         obprof = caraca(2,nrotv)
 209         oblopg = caraca(3,nrotv)
 210 #ifdef _DEBUG_HOMARD_
 211       write (ulsort,90002) 'typgeo', typgeo
 212       write (ulsort,90002) 'ngauss', ngauss
 213       write (ulsort,90002) 'nbensu', nbensu
 214       write (ulsort,90002) 'nbvapr', nbvapr
 215       write (ulsort,90002) 'nbtyas', nbtyas
 216       write (ulsort,90002) 'carsup', carsup
 217       write (ulsort,90002) 'typint', typint
 218       write (ulsort,90002) 'typcha', typcha
 219 #endif
 220 c
 221 c 2.2. ==> on cherche quelle fonction deja enregistree a ces
 222 c          caracteristiques
 223 c          quand on l'a, on ajoute le nombre de composantes
 224 c          si on ne la trouve pas, on en cree une
 225 c
 226         trouve = .false.
 227 c
 228         do 22 , nrfonc = 1 , nbfonc
 229 c
 230           if ( defonc( 1,nrfonc).eq.typgeo .and.
 231      >         defonc( 2,nrfonc).eq.ngauss .and.
 232      >         defonc( 3,nrfonc).eq.nbensu .and.
 233      >         defonc( 4,nrfonc).eq.nbvapr .and.
 234      >         defonc( 5,nrfonc).eq.nbtyas .and.
 235      >         defonc( 6,nrfonc).eq.carsup .and.
 236      >         defonc(11,nrfonc).eq.typint .and.
 237      >         defonc(12,nrfonc).eq.typcha .and.
 238      >         nofonc(1,nrfonc).eq.obprof .and.
 239      >         nofonc(3,nrfonc).eq.oblopg ) then
 240 c
 241             trouve = .true.
 242 c
 243             if ( carsup.ne.0 ) then
 244               if ( defonc(10,nrfonc).ne.nrocha ) then
 245                 trouve = .false.
 246               endif
 247             endif
 248 c
 249             do 221 , iaux = 1, nbtyas
 250               if ( defonc(20+iaux,nrfonc) .ne.
 251      >             caraen(20+iaux,nrotv) ) then
 252                 trouve = .false.
 253               endif
 254   221       continue
 255 c
 256             if ( trouve ) then
 257 #ifdef _DEBUG_HOMARD_
 258            write (ulsort,90002) 'Ajout de la composante numero ', nbcomp
 259            write (ulsort,90002) 'a la fonction numero ', nrfonc
 260 #endif
 261               defonc(7,nrfonc) = defonc(7,nrfonc) + nbcomp
 262               goto 21
 263             endif
 264 c
 265           endif
 266 c
 267    22   continue
 268 c
 269         nbfonc = nbfonc + 1
 270         defonc( 1,nrfonc) = typgeo
 271         defonc( 2,nrfonc) = ngauss
 272         defonc( 3,nrfonc) = nbensu
 273         defonc( 4,nrfonc) = nbvapr
 274         defonc( 5,nrfonc) = nbtyas
 275         defonc( 6,nrfonc) = carsup
 276         defonc( 7,nrfonc) = nbcomp
 277         defonc( 8,nrfonc) = 1
 278         defonc( 9,nrfonc) = 0
 279         defonc(10,nrfonc) = nrocha
 280         defonc(11,nrfonc) = typint
 281         defonc(12,nrfonc) = typcha
 282         do 220 , iaux = 1, nbtyas
 283           defonc(20+iaux,nrfonc) = caraen(20+iaux,nrotv)
 284   220   continue
 285         nofonc( 1,nrfonc) = obprof
 286         nofonc( 3,nrfonc) = oblopg
 287 c
 288 #ifdef _DEBUG_HOMARD_
 289         write (ulsort,*) '============================================='
 290         write (ulsort,*) 'Creation d''une nouvelle fonction'
 291         write (ulsort,texte(langue,36)) nompro, nbfonc
 292         write (ulsort,texte(langue,64)) defonc(1,nrfonc)
 293         write (ulsort,texte(langue,57)) defonc(2,nrfonc)
 294         write (ulsort,texte(langue,58)) defonc(3,nrfonc)
 295         write (ulsort,texte(langue,62)) defonc(4,nrfonc)
 296         do 229 , iaux = 1, defonc(5,nrfonc)
 297           write (ulsort,texte(langue,60)) defonc(20+iaux,nrfonc)
 298   229   continue
 299         write (ulsort,texte(langue,111)) defonc(7,nrfonc)
 300         if ( nbvapr.gt.0 ) then
 301           write (ulsort,texte(langue,84)) nofonc(1,nrfonc)
 302         endif
 303         write (ulsort,texte(langue,65+carsup))
 304         if ( oblopg.ne.blan08 ) then
 305           write (ulsort,texte(langue,83)) nofonc(3,nrfonc)
 306         endif
 307         write (ulsort,*) '============================================='
 308 #endif
 309 c
 310    21 continue
 311 c
 312 c====
 313 c 3. la fin
 314 c====
 315 c
 316       if ( codret.ne.0 ) then
 317 c
 318 #include "envex2.h"
 319 c
 320       write (ulsort,texte(langue,4)) nomcha
 321       write (ulsort,texte(langue,65+carsup))
 322       write (ulsort,texte(langue,5)) nrocha
 323       write (ulsort,texte(langue,1)) 'Sortie', nompro
 324       write (ulsort,texte(langue,2)) codret
 325 c
 326       endif
 327 c
 328 #ifdef _DEBUG_HOMARD_
 329       write (ulsort,texte(langue,1)) 'Sortie', nompro
 330       call dmflsh (iaux)
 331 #endif
 332 c
 333       end