src/tool/ES_MED/eslmmf.F

   1       subroutine eslmmf ( idfmed, nomamd,
   2      >                    typenh, typent, typgeo,
   3      >                    nmadeb, nbmato, nbelem, numfam,
   4      >                    typcon,
   5      >                    fammai,
   6      >                    tbiaux,
   7      >                    ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c  Entree-Sortie - Lecture d'un Maillage au format MED
  29 c  -      -        -            -                  -
  30 c                - Familles
  31 c                  -
  32 c ______________________________________________________________________
  33 c .        .     .        .                                            .
  34 c .  nom   . e/s . taille .           description                      .
  35 c .____________________________________________________________________.
  36 c . idfmed . e   .   1    . identificateur du fichier de               .
  37 c .        .     .        . maillage de sortie                         .
  38 c . nomamd . e   . char64 . nom du maillage MED                        .
  39 c . nmadeb . e   .   1    . numero de la maille de debut               .
  40 c .        .     .        .  >=0 : le tableau est pris tel quel        .
  41 c .        .     .        .   <0 : les descriptions sont inversees     .
  42 c . nbmato . e   .   1    . nombre de mailles a lire                   .
  43 c . nbelem . e   .   1    . nombre d'elements, tous types confondus    .
  44 c . numfam . e   .   1    . decalage dans la numerotation des familles .
  45 c .        .     .        .   1 : le tableau est pris tel quel         .
  46 c .        .     .        .  <=0 : le tableau passe negatif et est     .
  47 c .        .     .        .        decale de numfam                    .
  48 c . typenh . e   .   1    . code des entites au sens homard            .
  49 c .        .     .        .  -1 : noeuds                               .
  50 c .        .     .        .   0 : mailles-points                       .
  51 c .        .     .        .   1 : segments                             .
  52 c .        .     .        .   2 : triangles                            .
  53 c .        .     .        .   3 : tetraedres                           .
  54 c .        .     .        .   4 : quadrangles                          .
  55 c .        .     .        .   5 : pyramides                            .
  56 c .        .     .        .   6 : hexaedres                            .
  57 c .        .     .        .   7 : pentaedres                           .
  58 c . typent . e   .   1    . type des entites au sens MED               .
  59 c . typgeo . e   .   1    . type geometrique au sens MED               .
  60 c . typcon . e   .   1    . type de connectivite                       .
  61 c .        .     .        . 0 : par noeud (ednoda)                     .
  62 c .        .     .        . 1 : descendante (eddesc)                   .
  63 c . fammai .  s  . nbelem . famille med des mailles                    .
  64 c . tbiaux .     . nbelem . tableau tampon                             .
  65 c .        .     . *nbmane.                                            .
  66 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  67 c . langue . e   .    1   . langue des messages                        .
  68 c .        .     .        . 1 : francais, 2 : anglais                  .
  69 c . codret . es  .    1   . code de retour des modules                 .
  70 c .        .     .        . 0 : pas de probleme                        .
  71 c .        .     .        . 1 : probleme                               .
  72 c ______________________________________________________________________
  73 c
  74 c====
  75 c 0. declarations et dimensionnement
  76 c====
  77 c
  78 c 0.1. ==> generalites
  79 c
  80       implicit none
  81       save
  82 c
  83       character*6 nompro
  84       parameter ( nompro = 'ESLMMF' )
  85 c
  86 #include "nblang.h"
  87 #include "consts.h"
  88 c
  89 c 0.2. ==> communs
  90 c
  91 #include "envex1.h"
  92 #include "impr02.h"
  93 c
  94 c 0.3. ==> arguments
  95 c
  96       integer*8 idfmed
  97       integer typenh, typent, typgeo
  98       integer nmadeb, nbmato, nbelem, numfam
  99       integer typcon
 100       integer fammai(nbelem)
 101       integer tbiaux(*)
 102 c
 103       character*64 nomamd
 104 c
 105       integer ulsort, langue, codret
 106 c
 107 c 0.4. ==> variables locales
 108 c
 109 #include "meddc0.h"
 110 c
 111       integer iaux
 112       integer numdt, numit
 113       integer datype, chgt, tsf
 114       integer lgtfam
 115 c
 116       character*6 saux06
 117 c
 118       integer nbmess
 119       parameter ( nbmess = 150 )
 120       character*80 texte(nblang,nbmess)
 121 c ______________________________________________________________________
 122 c
 123 c====
 124 c 1. initialisations
 125 c====
 126 c
 127 c 1.1. ==> les messages
 128 c
 129 #include "impr01.h"
 130 c
 131 #ifdef _DEBUG_HOMARD_
 132       write (ulsort,texte(langue,1)) 'Entree', nompro
 133       call dmflsh (iaux)
 134 #endif
 135 c
 136       texte(1,4) = '(''... Lecture des '',i10,1x,a)'
 137       texte(1,63) = '(''Toutes les familles sont nulles.'')'
 138 c
 139       texte(2,4) = '(''... Readings of '',i10,1x,a)'
 140       texte(2,63) = '(''All the families are 0.'')'
 141 c
 142 #include "impr03.h"
 143 c
 144 #include "esimpr.h"
 145 c
 146 #ifdef _DEBUG_HOMARD_
 147       write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh)
 148 #endif
 149 c
 150       codret = 0
 151 c
 152 #ifdef _DEBUG_HOMARD_
 153       write (ulsort,90002) 'typcon', typcon
 154       write (ulsort,90002) 'typenh', typenh
 155       write (ulsort,90002) 'typent', typent
 156       write (ulsort,90002) 'typgeo', typgeo
 157       write (ulsort,90002) 'nmadeb', nmadeb
 158       write (ulsort,90002) 'nbmato', nbmato
 159       write (ulsort,90002) 'nbelem', nbelem
 160       write (ulsort,90002) 'numfam', numfam
 161 #endif
 162 c
 163       numdt = ednodt
 164       numit = ednoit
 165       chgt = 0
 166       tsf = 0
 167 c
 168 c====
 169 c 2. Longueur du tableau des familles
 170 c====
 171 c
 172       if ( codret.eq.0 ) then
 173 c
 174       datype = edda04
 175 #ifdef _DEBUG_HOMARD_
 176       write (ulsort,90002) 'numdt', numdt
 177       write (ulsort,90002) 'numit', numit
 178       write (ulsort,90002) 'typent', typent
 179       write (ulsort,90002) 'typgeo', typgeo
 180       write (ulsort,90002) 'datype', datype
 181       write (ulsort,90002) 'typcon', typcon
 182       write (ulsort,90002) 'chgt', chgt
 183       write (ulsort,90002) 'tsf', tsf
 184 #endif
 185 #ifdef _DEBUG_HOMARD_
 186       write (ulsort,texte(langue,3)) 'MMHNME', nompro
 187 #endif
 188       call mmhnme ( idfmed, nomamd, numdt, numit,
 189      >              typent, typgeo, datype, typcon, chgt, tsf,
 190      >              lgtfam, codret )
 191       if ( codret.ne.0 ) then
 192         saux06 = 'mmhnme'
 193       endif
 194 #ifdef _DEBUG_HOMARD_
 195       write (ulsort,90002) 'lgtfam', lgtfam
 196 #endif
 197 c
 198       endif
 199 c
 200 c====
 201 c 3. Remplissage du tableau
 202 c====
 203 c 3.1. ==> 0 par defaut
 204 c
 205       if ( lgtfam.eq.0 ) then
 206 c
 207         if ( codret.eq.0 ) then
 208 c
 209 #ifdef _DEBUG_HOMARD_
 210       write (ulsort,texte(langue,63))
 211 #endif
 212 c
 213         if ( nmadeb.ge.0 ) then
 214           do 311 , iaux = 1, nbmato
 215             fammai(nmadeb-1+iaux) = 0
 216   311     continue
 217         else
 218           do 312 , iaux = 1, nbmato
 219             fammai(iaux) = 0
 220   312     continue
 221         endif
 222 c
 223         endif
 224 c
 225 c 3.2. ==> lecture
 226 c
 227       else
 228 c
 229         if ( codret.eq.0 ) then
 230 c
 231 #ifdef _DEBUG_HOMARD_
 232       write (ulsort,texte(langue,3)) 'MMHFNR', nompro
 233 #endif
 234         call mmhfnr ( idfmed, nomamd, numdt, numit,
 235      >                typent, typgeo,
 236      >                tbiaux, codret )
 237         if ( codret.ne.0 ) then
 238           saux06 = 'mmhfnr'
 239         endif
 240 c
 241         endif
 242 c
 243         if ( codret.eq.0 ) then
 244 c
 245         if ( numfam.gt.0 ) then
 246 c
 247           if ( nmadeb.ge.0 ) then
 248             do 321 , iaux = 1, nbmato
 249              fammai(nmadeb-1+iaux) = tbiaux(iaux)
 250   321       continue
 251           else
 252             do 322 , iaux = 1, nbmato
 253              fammai(iaux) = tbiaux(iaux)
 254   322       continue
 255           endif
 256 c
 257         else
 258 c
 259           if ( nmadeb.ge.0 ) then
 260             do 323 , iaux = 1, nbmato
 261               fammai(nmadeb-1+iaux) = -tbiaux(iaux) + numfam
 262   323       continue
 263           else
 264             do 324 , iaux = 1, nbmato
 265               fammai(iaux) = -tbiaux(iaux) + numfam
 266   324       continue
 267           endif
 268 c
 269         endif
 270 c
 271       endif
 272 c
 273       endif
 274 c
 275 c====
 276 c 4. la fin
 277 c====
 278 c
 279       if ( codret.ne.0 ) then
 280 c
 281 #include "envex2.h"
 282 c
 283       write (ulsort,texte(langue,1)) 'Sortie', nompro
 284       write (ulsort,texte(langue,2)) codret
 285       write (ulsort,texte(langue,4)) nbmato, mess14(langue,3,typenh)
 286       write (ulsort,texte(langue,78)) saux06, codret
 287       write (ulsort,texte(langue,79))
 288 c
 289       endif
 290 c
 291 #ifdef _DEBUG_HOMARD_
 292       write (ulsort,texte(langue,1)) 'Sortie', nompro
 293       call dmflsh (iaux)
 294 #endif
 295 c
 296       end