src/tool/Information/infve5.F

   1       subroutine infve5 ( typenh, nbfato, volfac, pypefa,
   2      >                    hetfac,
   3      >                    numniv, numblo, nubnvo,
   4      >                    tbaux2,
   5      >                    ulsort, langue, codret )
   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   INformation : Fichier VEctoriel - 5eme partie
  27 c   --            -       --          -
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . typenh . e   .   1    . code des entites au sens homard            .
  33 c .        .     .        .   2 : triangles                            .
  34 c .        .     .        .   4 : quadrangles                          .
  35 c . nbfato . e   .   1    .nombre de faces total                       .
  36 c . volfac . e   .2*nbfato. numeros des 2 volumes par face             .
  37 c .        .     .        . volfac(i,k) definit le i-eme voisin de k   .
  38 c .        .     .        .   0 : pas de voisin                        .
  39 c .        .     .        . j>0 : hexaedre/tetraedre j                 .
  40 c .        .     .        . j<0 : pyramide/pentaedre dans pypefa(1/2,j).
  41 c . pypefa . e   .2*lgpype. pypefa(1,j) = numero de la pyramide voisine.
  42 c .        .     .        . de la face k tel que volfac(1/2,k) = -j    .
  43 c .        .     .        . pypefa(2,j) = numero du pentaedre voisin   .
  44 c .        .     .        . de la face k tel que volfac(1/2,k) = -j    .
  45 c . hetfac . e   . nbfato . historique de l'etat des faces             .
  46 c . numniv . e   .   1    . numero du niveau a tracer                  .
  47 c .        .     .        . -1 : tous les niveaux                      .
  48 c . numblo . e   .   1    . numero du bloc a tracer                    .
  49 c .        .     .        . 0 : trace du domaine global                .
  50 c . nubnvo . e   .   *    . . si numblo>0 : numero de blocs des volumes.
  51 c .        .     .        . . si numniv >=0 : niveau des volumes       .
  52 c .        .     .        . Rangement :                                .
  53 c .        .     .        . les tetraedres                             .
  54 c .        .     .        . les hexaedres                              .
  55 c .        .     .        . les pyramides                              .
  56 c .        .     .        . les pentaedres                             .
  57 c . tbaux2 . es  .-nbquto:. tableau de travail                         .
  58 c .        .     .nbt/arto.                                            .
  59 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  60 c . langue . e   .    1   . langue des messages                        .
  61 c .        .     .        . 1 : francais, 2 : anglais                  .
  62 c . codret . es  .    1   . code de retour des modules                 .
  63 c .        .     .        . 0 : pas de 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 = 'INFVE5' )
  77 c
  78 #include "nblang.h"
  79 c
  80 c 0.2. ==> communs
  81 c
  82 #include "envex1.h"
  83 #include "nombqu.h"
  84 #include "nombte.h"
  85 #include "nombhe.h"
  86 #include "nombpy.h"
  87 #include "impr02.h"
  88 c
  89 c 0.3. ==> arguments
  90 c
  91       integer typenh, nbfato
  92       integer volfac(2,nbfato), pypefa(2,*)
  93       integer hetfac(nbfato)
  94       integer numniv, numblo, nubnvo(*)
  95       integer tbaux2(-nbquto:*)
  96 c
  97       integer ulsort, langue, codret
  98 c
  99 c 0.4. ==> variables locales
 100 c
 101       integer iaux, jaux, kaux, laux
 102       integer maxtet, maxhex, maxpyr
 103       integer dectet, dechex, decpyr, decpen, decvol
 104       integer nument, etaent, numen2
 105 c
 106       integer nbmess
 107       parameter ( nbmess = 10 )
 108       character*80 texte(nblang,nbmess)
 109 c_______________________________________________________________________
 110 c
 111 c====
 112 c 1. prealables
 113 c====
 114 c 1.1. ==> messages
 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) = '(/,''Trace du domaine global'')'
 124       texte(1,5) = '(/,''Examen du '',a,'' numero'',i6)'
 125       texte(1,6) = '(''Trace de tous les niveaux'')'
 126       texte(1,7) = '(''Trace du niveau numero'',i6)'
 127       texte(1,8) = '(''Recherche des '',a,'' a tracer'')'
 128 c
 129       texte(2,4) = '(/,''Writings of the whole domain)'
 130       texte(2,5) = '(/,''Examination of '',a,'' #'',i6)'
 131       texte(2,6) = '(''Writings of all the levels'')'
 132       texte(2,7) = '(''Writings for the level #'',i6)'
 133       texte(2,8) = '(''Search of the '',a,'' for plotting'')'
 134 c
 135 #include "impr03.h"
 136 c
 137       codret = 0
 138 c
 139 #ifdef _DEBUG_HOMARD_
 140       if ( numblo.eq.0 ) then
 141         write (ulsort,texte(langue,4))
 142       else
 143         write (ulsort,texte(langue,5)) numblo
 144       endif
 145       if ( numniv.eq.-1 ) then
 146         write (ulsort,texte(langue,6))
 147       else
 148         write (ulsort,texte(langue,7)) numniv
 149       endif
 150       write (ulsort,texte(langue,8)) mess14(langue,3,typenh)
 151 #endif
 152 c
 153 c 1.2. ==> decalages
 154 c
 155       dectet = 0
 156       maxtet = dectet + nbteto
 157       dechex = maxtet
 158       maxhex = dechex + nbheto
 159       decpyr = maxhex
 160       maxpyr = decpyr + nbpyto
 161       decpen = maxpyr
 162 c
 163 c 1.3. ==> Particularites selon le type de mailles tria/quad :
 164 c          . Diviseur pour trouver l'etat actif
 165 c          . Decalage dans la numerotation des volumes
 166 c
 167       if ( typenh.eq.2 ) then
 168         etaent = 10
 169         decvol = dectet
 170       else
 171         etaent = 100
 172         decvol = dechex
 173       endif
 174 c
 175 c====
 176 c 2. Recherche des faces a tracer :
 177 c    On trace une face seulement si elle est active et
 178 c    . si elle appartient a une region bidimensionnelle du maillage, et
 179 c      si elle appartient au bloc ou au niveau retenu
 180 c    . si elle est une face ayant un et un seul element volumique
 181 c      voisin, et si ce volume appartient au bloc ou au niveau retenu
 182 c    . si elle est une face ayant deux elements volumiques voisins,
 183 c      et si un et un seul des volumes appartient au bloc ou au niveau
 184 c      retenu
 185 c
 186 c    La convention est la suivante :
 187 c    * tbaux2(iaux) vaut 0 si la face est d'une region 2D, du bloc ou
 188 c      du niveau retenu
 189 c    * tbaux2(iaux) vaut 1 si la face borde un domaine volumique, du
 190 c      bloc ou du niveau retenu
 191 c    * tbaux2(iaux) vaut 2 si la face est interne a un domaine
 192 c      volumique, un et un seul des voisins appartenant au bloc ou au
 193 c      niveau retenu
 194 c    * tbaux2(iaux) vaut -1 sinon
 195 c    On tracera donc pour tbaux2(iaux) >= 0
 196 c====
 197 c
 198 c 2.1. ==> Cas du domaine global avec tous les niveaux
 199 c          On examine les faces actives et on retient celles avec au
 200 c          plus un voisin
 201 c
 202       if ( numblo.eq.0 .and. numniv.eq.-1 ) then
 203 c
 204         do 21 , iaux = 1, nbfato
 205 #ifdef _DEBUG_HOMARD_
 206        write (ulsort,texte(langue,5)) mess14(langue,1,typenh), iaux
 207        write (ulsort,90002) 'voisins', volfac(1,iaux),volfac(2,iaux)
 208 #endif
 209 c
 210 c         . La face est active
 211           if ( mod(hetfac(iaux),etaent).eq.0 ) then
 212 c
 213 c           . La face n'a pas deux voisins
 214             if ( volfac(2,iaux).eq.0 ) then
 215 c
 216               if ( typenh.eq.2 ) then
 217                 jaux = iaux
 218               else
 219                 jaux = -iaux
 220               endif
 221 c             . La face est 2D
 222               if ( volfac(1,iaux).eq.0 ) then
 223                 tbaux2(jaux) = 0
 224 c             . La face a un seul voisin
 225               else
 226                 tbaux2(jaux) = 1
 227               endif
 228 c
 229             endif
 230 c
 231           endif
 232 c
 233    21   continue
 234 c
 235 c 2.2. ==> Cas d'un filtrage par bloc volumique
 236 c          On examine les faces actives et on retient celles avec au
 237 c          plus un voisin, ce voisin etant du bon bloc
 238 c          Remarque : avec deux voisins, le bloc est forcement le meme
 239 c
 240       elseif ( numblo.gt.0 ) then
 241 c
 242         do 22 , iaux = 1, nbfato
 243 c
 244 c         . La face est active
 245           if ( mod(hetfac(iaux),etaent).eq.0 ) then
 246 c
 247 #ifdef _DEBUG_HOMARD_
 248        if ( typenh.eq.2 ) then
 249          jaux = iaux
 250        else
 251          jaux = -iaux
 252        endif
 253        write (ulsort,90002) mess14(langue,2,typenh), iaux, tbaux2(jaux)
 254 #endif
 255 c
 256 c           . La face n'a pas deux voisins
 257             if ( volfac(2,iaux).eq.0 ) then
 258 #ifdef _DEBUG_HOMARD_
 259        write (ulsort,90002) '. voisins',volfac(1,iaux),volfac(2,iaux)
 260 #endif
 261 c
 262 c           . La face a un seul voisin
 263               kaux = volfac(1,iaux)
 264               if ( kaux.ne.0 ) then
 265 c
 266 c 2.2.1. ==> reperage du numero d'entite de ce voisin, avec le decalage
 267 c            pour le reperage des blocs
 268 c
 269                 if ( kaux.gt.0 ) then
 270                   nument = decvol + kaux
 271                 else
 272                   if ( pypefa(1,-kaux).ne.0 ) then
 273                     nument = decpyr + pypefa(1,-kaux)
 274                   else
 275                     nument = decpen + pypefa(2,-kaux)
 276                   endif
 277                 endif
 278 cgn      write (ulsort,90002)
 279 cgn     > '. '//mess14(langue,1,3),nument,nubnvo(nument)
 280 c
 281 c 2.2.2. ==> Choix en fonction du bloc du voisin
 282 c
 283                 if ( nubnvo(nument).eq.numblo ) then
 284                   if ( typenh.eq.2 ) then
 285                     jaux = iaux
 286                   else
 287                     jaux = -iaux
 288                   endif
 289                   tbaux2(jaux) = 1
 290                 endif
 291 c
 292               endif
 293 c
 294             endif
 295 c
 296           endif
 297 #ifdef _DEBUG_HOMARD_
 298        if ( typenh.eq.2 ) then
 299          jaux = iaux
 300        else
 301          jaux = -iaux
 302        endif
 303        if ( tbaux2(jaux).ne.-1 ) then
 304        write (ulsort,90002) '==> On la trace', tbaux2(jaux)
 305        endif
 306 #endif
 307 c
 308    22   continue
 309 c
 310 c 2.3. ==> Cas d'un filtrage par niveau
 311 c          On examine les faces actives et on retient celles :
 312 c          . avec un seul voisin, ce voisin etant du bon niveau
 313 c          . avec deux voisins, un et un seul des voisins etant
 314 c            du bon niveau
 315 c
 316       else
 317 c
 318         do 23 , iaux = 1, nbfato
 319 c
 320 c         . La face est active
 321           if ( mod(hetfac(iaux),etaent).eq.0 ) then
 322 c
 323 c           . La face a au moins un voisin
 324             kaux = volfac(1,iaux)
 325             if ( kaux.ne.0 ) then
 326 c
 327 c 2.3.1. ==> reperage du numero d'entite de ce voisin, avec le decalage
 328 c            pour le reperage des blocs
 329 c
 330               if ( kaux.gt.0 ) then
 331                 nument = decvol + kaux
 332               else
 333                 if ( pypefa(1,-kaux).ne.0 ) then
 334                   nument = decpyr + pypefa(1,-kaux)
 335                 else
 336                   nument = decpen + pypefa(2,-kaux)
 337                 endif
 338               endif
 339 c
 340 c 2.3.2. ==> . La face a un seul voisin : choix en fonction du niveau
 341 c
 342               laux = volfac(2,iaux)
 343               if ( laux.eq.0 ) then
 344 c
 345                 if ( nubnvo(nument).eq.numniv ) then
 346                   if ( typenh.eq.2 ) then
 347                     jaux = iaux
 348                   else
 349                     jaux = -iaux
 350                   endif
 351                   tbaux2(jaux) = 1
 352                 endif
 353 c
 354 c 2.3.3. ==> . La face a 2 voisins : choix en fonction de leurs niveaux
 355 c
 356               else
 357 c
 358                 if ( laux.gt.0 ) then
 359                   numen2 = decvol + laux
 360                 else
 361                   if ( kaux.eq.laux ) then
 362                     numen2 = decpen + pypefa(2,-laux)
 363                   else
 364                     if ( pypefa(1,-laux).ne.0 ) then
 365                       numen2 = decpyr + pypefa(1,-laux)
 366                     else
 367                       numen2 = decpen + pypefa(2,-laux)
 368                     endif
 369                   endif
 370                 endif
 371                 if ( nubnvo(nument).eq.numniv .or.
 372      >               nubnvo(numen2).eq.numniv ) then
 373                   if ( nubnvo(nument).ne.nubnvo(numen2) ) then
 374                     if ( typenh.eq.2 ) then
 375                       jaux = iaux
 376                     else
 377                       jaux = -iaux
 378                     endif
 379                     tbaux2(jaux) = 2
 380                   endif
 381                 endif
 382 c
 383               endif
 384 c
 385             endif
 386 c
 387           endif
 388 c
 389    23   continue
 390 c
 391       endif
 392 c
 393 c====
 394 c 3. la fin
 395 c====
 396 c
 397       if ( codret.ne.0 ) then
 398 c
 399 #include "envex2.h"
 400 c
 401       write (ulsort,texte(langue,1)) 'Sortie', nompro
 402       write (ulsort,texte(langue,2)) codret
 403 c
 404       endif
 405 c
 406 #ifdef _DEBUG_HOMARD_
 407       write (ulsort,texte(langue,1)) 'Sortie', nompro
 408       call dmflsh (iaux)
 409 #endif
 410 c
 411       end