src/tool/ES_HOMARD/esle02.F

   1       subroutine esle02 ( idfmed,
   2      >                    typenh, nhenti, nbenca,
   3      >                    ulsort, langue, codret)
   4 c
   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 noeud-maille - 02
  26 c  -      -        --                     --
  27 c ______________________________________________________________________
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . idfmed . e   .   1    . identificateur du fichier MED              .
  31 c . typenh . e   .   1    . code des entites                           .
  32 c .        .     .        .  -1 : noeuds                               .
  33 c .        .     .        .   0 : mailles-points                       .
  34 c .        .     .        .   1 : aretes                               .
  35 c .        .     .        .   2 : triangles                            .
  36 c .        .     .        .   3 : tetraedres                           .
  37 c .        .     .        .   4 : quadrangles                          .
  38 c .        .     .        .   5 : pyramides                            .
  39 c .        .     .        .   6 : hexaedres                            .
  40 c .        .     .        .   7 : pentaedres                           .
  41 c . nhenti . e   . char*8 . objet decrivant l'entite                   .
  42 c . nbenca . e   .   1    . nombre d'entites decrites par aretes       .
  43 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  44 c . langue . e   .    1   . langue des messages                        .
  45 c .        .     .        . 1 : francais, 2 : anglais                  .
  46 c . codret . es  .    1   . code de retour des modules                 .
  47 c .        .     .        . 0 : pas de probleme                        .
  48 c ______________________________________________________________________
  49 c
  50 c====
  51 c 0. declarations et dimensionnement
  52 c====
  53 c
  54 c 0.1. ==> generalites
  55 c
  56       implicit none
  57       save
  58 c
  59       character*6 nompro
  60       parameter ( nompro = 'ESLE02' )
  61 c
  62 #include "nblang.h"
  63 #include "consts.h"
  64 c
  65 c 0.2. ==> communs
  66 c
  67 #include "envex1.h"
  68 c
  69 #include "gmenti.h"
  70 c
  71 #include "impr02.h"
  72 #include "enti01.h"
  73 c
  74 c 0.3. ==> arguments
  75 c
  76       integer*8 idfmed
  77       integer typenh
  78       integer nbenca
  79 c
  80       character*8 nhenti
  81 c
  82       integer ulsort, langue, codret
  83 c
  84 c 0.4. ==> variables locales
  85 c
  86 #include "meddc0.h"
  87 c
  88       integer iaux, jaux, kaux, laux
  89       integer nbprof
  90       integer nbvapr, adins2
  91       integer typpro
  92       integer adcoar
  93       integer codre1, codre2, codre3
  94       integer codre0
  95       integer tabaux(3)
  96 c
  97       character*1 saux01(2)
  98       character*64 noprof
  99       character*64 saux64
 100 c
 101       logical afaire
 102 c
 103       integer nbmess
 104       parameter ( nbmess = 150 )
 105       character*80 texte(nblang,nbmess)
 106 c
 107 c 0.5. ==> initialisation
 108 c
 109       data saux01 / 'A', 'B' /
 110 c ______________________________________________________________________
 111 c
 112 c====
 113 c 1. initialisation
 114 c====
 115 c
 116 #include "impr01.h"
 117 c
 118 #ifdef _DEBUG_HOMARD_
 119       write (ulsort,texte(langue,1)) 'Entree', nompro
 120       call dmflsh (iaux)
 121 #endif
 122 c
 123       texte(1,4) = '(''... Lecture des profils pour les '',a)'
 124 c
 125       texte(2,4) = '(''... Readings of profiles for '',a)'
 126 c
 127 #ifdef _DEBUG_HOMARD_
 128       write (ulsort,texte(langue,4)) mess14(langue,3,typenh)
 129 #endif
 130 c
 131 #include "impr03.h"
 132 c
 133 #include "esimpr.h"
 134 c
 135 #ifdef _DEBUG_HOMARD_
 136       write (ulsort,90002) 'nbenca', nbenca
 137 #endif
 138 c
 139 c====
 140 c 2. Lecture sous forme de profil pour les informations supplementaires
 141 c====
 142 #ifdef _DEBUG_HOMARD_
 143       write (ulsort,90002) '2. Lecture profil ; codret', codret
 144 #endif
 145 c 2.1. ==> Nombre de profils
 146 c
 147       if ( codret.eq.0 ) then
 148 c
 149 #ifdef _DEBUG_HOMARD_
 150       write (ulsort,texte(langue,3)) 'MPFNPF', nompro
 151 #endif
 152       call mpfnpf ( idfmed, nbprof, codret )
 153 #ifdef _DEBUG_HOMARD_
 154       write (ulsort,texte(langue,86)) nbprof
 155 #endif
 156 c
 157       endif
 158 c
 159 c 2.2. ==> Parcours des profils
 160 #ifdef _DEBUG_HOMARD_
 161       write (ulsort,90002) '2.2. ==> Parcours profil ; codret', codret
 162 #endif
 163 c
 164       if ( codret.eq.0 ) then
 165 c
 166       afaire = .true.
 167 c
 168       do 22 , iaux = 1 , nbprof
 169 c
 170 c 2.2.1. ==> nom et taille du profil a lire
 171 #ifdef _DEBUG_HOMARD_
 172       write (ulsort,90032) 'Profil numero', iaux
 173 #endif
 174 c
 175         if ( codret.eq.0 ) then
 176 c
 177         jaux = iaux
 178 c
 179 #ifdef _DEBUG_HOMARD_
 180       write (ulsort,texte(langue,3)) 'MPFPFI', nompro
 181 #endif
 182         call mpfpfi ( idfmed, jaux, noprof, nbvapr, codret )
 183         if ( codret.ne.0 ) then
 184         write (ulsort,texte(langue,79))
 185         endif
 186 c
 187 #ifdef _DEBUG_HOMARD_
 188         write (ulsort,texte(langue,61)) noprof
 189         write (ulsort,texte(langue,62)) nbvapr
 190 #endif
 191 c
 192         endif
 193 c
 194 c 2.2.2. ==> On ne continue que pour les informations supplementaires,
 195 c            les recollements ou les connectivites par arete
 196 #ifdef _DEBUG_HOMARD_
 197       write (ulsort,90002) '2.2.2. suite ; codret', codret
 198 #endif
 199 c
 200         if ( codret.eq.0 ) then
 201 c
 202         typpro = 0
 203         saux64 = blan64
 204 c                      12                      34567890
 205         saux64(1:10) = suffix(3,typenh)(1:2)//'InfoSup2'
 206         if ( noprof.eq.saux64 ) then
 207           typpro = -1
 208         endif
 209 c
 210         if ( typpro.eq.0 ) then
 211 c
 212           saux64 = blan64
 213 c                        12                      3456789012
 214           saux64(1:12) = suffix(3,typenh)(1:2)//'_Recollem_'
 215           if ( noprof(1:12).eq.saux64(1:12) ) then
 216             typpro = -2
 217           endif
 218 c
 219         endif
 220 c
 221         if ( typpro.eq.0 ) then
 222 c
 223           saux64 = blan64
 224 c                        12                      3456789012
 225           saux64(1:12) = suffix(3,typenh)(1:2)//'_ConnAret_'
 226           if ( noprof(1:12).eq.saux64(1:12) ) then
 227             read ( noprof(13:14) , fmt='(i2)' ) typpro
 228           endif
 229 c
 230         endif
 231 c
 232 #ifdef _DEBUG_HOMARD_
 233         write (ulsort,90002) 'typpro', typpro
 234         if ( typpro.gt.0 ) then
 235           write (ulsort,texte(langue,61)) noprof
 236           write (ulsort,texte(langue,62)) nbvapr
 237         endif
 238 #endif
 239 c
 240         endif
 241 c
 242 c 2.2.3. ==> informations supplementaires
 243 #ifdef _DEBUG_HOMARD_
 244       write (ulsort,90002) '2.2.3. infos compl. ; codret', codret
 245       write (ulsort,90002) 'typpro', typpro
 246 #endif
 247 c
 248         if ( codret.eq.0 ) then
 249 c
 250         if ( typpro.eq.-1 ) then
 251 c
 252 c 2.2.3.1. ==> Allocation du tableau receptacle
 253 c
 254           if ( codret.eq.0 ) then
 255           call gmaloj ( nhenti//'.InfoSup2', ' ',
 256      >                  nbvapr, adins2, codret )
 257           endif
 258 c
 259 c 2.2.3.2. ==> Lecture de la liste des valeurs
 260 c
 261           if ( codret.eq.0 ) then
 262 c
 263 #ifdef _DEBUG_HOMARD_
 264       write (ulsort,texte(langue,3)) 'MPFPRR pour InfoSup2', nompro
 265 #endif
 266           call mpfprr ( idfmed, noprof, imem(adins2), codret )
 267 c
 268           endif
 269 c
 270 c 2.2.4. ==> recollements
 271 c
 272         elseif ( typpro.eq.-2 ) then
 273 c
 274 c 2.2.4.1. ==> Allocation de la structure generale si maille
 275 c
 276           if ( codret.eq.0 ) then
 277 c
 278           if ( afaire ) then
 279             if ( typenh.ge.0 ) then
 280               call gmaloj ( nhenti//'.Recollem', ' ', 0, jaux, codret )
 281             endif
 282             afaire = .false.
 283           endif
 284 c
 285           endif
 286 c
 287 c 2.2.4.2. ==> Attributs
 288 c
 289 c                           345678901
 290           saux64(13:21) = 'Attributs'
 291           if ( noprof.eq.saux64 ) then
 292 c
 293             if ( codret.eq.0 ) then
 294 #ifdef _DEBUG_HOMARD_
 295             write (ulsort,texte(langue,3)) 'MPFPRR / '//saux64, nompro
 296 #endif
 297             call mpfprr ( idfmed, noprof, tabaux, codret )
 298 c
 299             endif
 300 c
 301             if ( codret.eq.0 ) then
 302 c
 303             call gmecat ( nhenti//'.Recollem', 1, tabaux(1), codre1 )
 304             call gmecat ( nhenti//'.Recollem', 2, tabaux(2), codre2 )
 305             call gmecat ( nhenti//'.Recollem', 3, tabaux(3), codre3 )
 306 c
 307             codre0 = min ( codre1, codre2, codre3 )
 308             codret = max ( abs(codre0), codret,
 309      >                     codre1, codre2, codre3 )
 310 c
 311             endif
 312 c
 313           endif
 314 c
 315 c 2.2.4.3. ==> listes
 316 c
 317           if ( typenh.ge.0 ) then
 318             laux = 2
 319           else
 320             laux = 1
 321           endif
 322 c
 323           do 2243 , jaux = 1 , laux
 324 c
 325 c                          34567   8              901
 326           saux64(13:21) = 'Liste'//saux01(jaux)//'   '
 327           if ( noprof.eq.saux64 ) then
 328 c
 329             if ( codret.eq.0 ) then
 330 c
 331             if ( typenh.ge.0 ) then
 332               call gmaloj ( nhenti//'.Recollem.Liste'//saux01(jaux),
 333      >                     ' ',  nbvapr, kaux, codret )
 334             else
 335               call gmaloj ( nhenti//'.Recollem',
 336      >                      ' ', nbvapr, kaux, codret )
 337             endif
 338 c
 339             endif
 340 c
 341             if ( codret.eq.0 ) then
 342 #ifdef _DEBUG_HOMARD_
 343             write (ulsort,texte(langue,3)) 'MPFPRR / '//saux64, nompro
 344 #endif
 345             call mpfprr ( idfmed, noprof, imem(kaux), codret )
 346 c
 347             endif
 348 c
 349           endif
 350 c
 351  2243     continue
 352 c
 353 c 2.2.5. ==> suite de la connectivite par aretes
 354 c
 355         elseif ( typpro.gt.0 ) then
 356 c
 357           if ( codret.eq.0 ) then
 358 c
 359           call gmadoj ( nhenti//'.ConnAret', adcoar, jaux, codre0 )
 360 c
 361           codret = max ( abs(codre0), codret )
 362 c
 363           endif
 364 c
 365           if ( codret.eq.0 ) then
 366 c
 367           jaux = adcoar + nbenca*(typpro-1)
 368 #ifdef _DEBUG_HOMARD_
 369       write (ulsort,texte(langue,3)) 'MPFPRR / '//noprof, nompro
 370 #endif
 371           call mpfprr ( idfmed, noprof, imem(jaux), codret )
 372 cgn        write(ulsort,*) imem(jaux)
 373 c
 374           endif
 375 c
 376         endif
 377 c
 378         endif
 379 c
 380    22 continue
 381 c
 382       endif
 383 cgn      call gmprsx ( nompro,nhenti//'.ConnAret' )
 384 cgn      call gmprsx ( nompro,nhenti//'.Recollem' )
 385 c
 386 c====
 387 c 3. la fin
 388 c====
 389 c
 390       if ( codret.ne.0 ) then
 391 c
 392 #include "envex2.h"
 393 c
 394       write (ulsort,texte(langue,1)) 'Sortie', nompro
 395       write (ulsort,texte(langue,2)) codret
 396 c
 397       endif
 398 c
 399 #ifdef _DEBUG_HOMARD_
 400       write (ulsort,texte(langue,1)) 'Sortie', nompro
 401       call dmflsh (iaux)
 402 #endif
 403 c
 404       end