src/tool/Information/infovo.F

   1       subroutine infovo ( typmes, nufade, nufafi, volint,
   2      >                    voltri, pypetr,
   3      >                    volqua, pypequ,
   4      >                    hettet, hetpyr, hethex, hetpen,
   5      >                    trav1a, trav2a,
   6      >                    ulecr,
   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   INFOrmation : VOisins
  29 c   ----          --
  30 c ______________________________________________________________________
  31 c .        .     .        .                                            .
  32 c .  nom   . e/s . taille .           description                      .
  33 c .____________________________________________________________________.
  34 c . typmes . e   .   1    .  0 : message pour les faces                .
  35 c .        .     .        . 40 : message pour les tetra-penta-hexaedres.
  36 c .        .     .        . 50 : message pour les pyramides            .
  37 c . nufade . e   .   1    . numero initial de la liste des faces       .
  38 c . nufafi . e   .   1    . numero final de la liste des faces         .
  39 c . volint . e   .  4**   . i,0 : nombre de volumes interdits          .
  40 c .        .     .        . i,j>0 : numeros des volumes interdits      .
  41 c .        .     .        . i=1 : tetr, i=2 : hexa, i=3 : pyra,        .
  42 c .        .     .        . i=4 : pent                                 .
  43 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  44 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  45 c .        .     .        .   0 : pas de voisin                        .
  46 c .        .     .        . j>0 : tetraedre j                          .
  47 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  48 c . pypetr . e   .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
  49 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  50 c .        .     .        . pypetr(2,j) = numero du pentaedre voisin   .
  51 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  52 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  53 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  54 c .        .     .        .   0 : pas de voisin                        .
  55 c .        .     .        . j>0 : hexaedre j                           .
  56 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  57 c . pypequ . e   .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
  58 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  59 c .        .     .        . pypequ(2,j) = numero du pentaedre voisin   .
  60 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  61 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  62 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  63 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  64 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  65 c . trav1a . a   .   *    . tableau de travail numero 1                .
  66 c . trav2a . a   .   *    . liste des faces a examiner                 .
  67 c .        .     .        . . numero positif si triangle               .
  68 c .        .     .        . . numero negatif si quadrangle             .
  69 c . ulecr  . e   .   1    . unite logique pour l'ecriture              .
  70 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  71 c . langue . e   .    1   . langue des messages                        .
  72 c .        .     .        . 1 : francais, 2 : anglais                  .
  73 c . codret . es  .    1   . code de retour des modules                 .
  74 c .        .     .        . 0 : pas de probleme                        .
  75 c .        .     .        . non nul : probleme                         .
  76 c ______________________________________________________________________
  77 c
  78 c====
  79 c 0. declarations et dimensionnement
  80 c====
  81 c
  82 c 0.1. ==> generalites
  83 c
  84       implicit none
  85       save
  86 c
  87       character*6 nompro
  88       parameter ( nompro = 'INFOVO' )
  89 c
  90 #include "nblang.h"
  91 #include "tbdim0.h"
  92 c
  93 c 0.2. ==> communs
  94 c
  95 #include "envex1.h"
  96 #include "inmess.h"
  97 #include "impr02.h"
  98 c
  99 #include "nombtr.h"
 100 #include "nombqu.h"
 101 #include "nombte.h"
 102 #include "nombpy.h"
 103 #include "nombhe.h"
 104 #include "nombpe.h"
 105 #include "hexcf0.h"
 106 #include "hexcf1.h"
 107 c
 108 c 0.3. ==> arguments
 109 c
 110       integer typmes
 111       integer nufade, nufafi
 112       integer volint(4,0:*)
 113       integer voltri(2,nbtrto), pypetr(2,*)
 114       integer volqua(2,nbquto), pypequ(2,*)
 115       integer hettet(nbteto)
 116       integer hetpyr(nbpyto)
 117       integer hethex(nbheto)
 118       integer hetpen(nbpeto)
 119 c
 120       integer trav1a(tbdim), trav2a(tbdim)
 121 c
 122       integer ulecr
 123       integer ulsort, langue, codret
 124 c
 125 c 0.4. ==> variables locales
 126 c
 127       integer iaux, jaux, kaux
 128       integer nument, decafv
 129       integer etat, bindec
 130       integer letetr, lehexa, lapyra, lepent
 131       integer nbtetr, nbhexa, nbpyra, nbpent
 132       integer nbtevr, nbhevr, nbpyvr, nbpevr
 133       integer inditv (0:2,0:2,0:2,0:2)
 134 c
 135       character*40 taux40
 136 c
 137       integer nbmess
 138       parameter ( nbmess = 10 )
 139       character*80 texte(nblang,nbmess)
 140 c ______________________________________________________________________
 141 c
 142 c====
 143 c 1. initialisation
 144 c====
 145 c 1.1. ==> messages
 146 c
 147 #include "impr01.h"
 148 #include "infoen.h"
 149 c
 150 #ifdef _DEBUG_HOMARD_
 151       write (ulsort,texte(langue,1)) 'Entree', nompro
 152       call dmflsh (iaux)
 153 #endif
 154 c
 155       texte(1,4) = '(''Examen de'',i10,'' face(s).'')'
 156       texte(1,5) = '(''Nombre de '',a,'' interdits :'',i10)'
 157       texte(1,6) = '(''.. '',a,''numero'',i10)'
 158       texte(1,7) = '(''Nombre de '',a,'' :'',i10)'
 159 c
 160       texte(2,4) = '(''Examination of'',i10,'' face(s).'')'
 161       texte(2,5) = '(''Number of '',,a,'' which are forbiden :'',i10)'
 162       texte(2,6) = '(''.. '',a,''#'',i10)'
 163       texte(2,7) = '(''Number of '',,a,'':'',i10)'
 164 c
 165 #include "impr03.h"
 166 c
 167 #include "tbdim1.h"
 168 c
 169 #ifdef _DEBUG_HOMARD_
 170       write (ulsort,texte(langue,4)) nufafi-nufade+1
 171       write (ulsort,90002) 'Numeros',(trav2a(jaux),jaux=nufade,nufafi)
 172 #endif
 173 c
 174 c 1.2. ==> indirections dans les messages
 175 c
 176       inditv(1,0,0,0) = 1 + typmes
 177       inditv(2,0,0,0) = 2 + typmes
 178       inditv(0,1,0,0) = 3 + typmes
 179       inditv(0,2,0,0) = 4 + typmes
 180       inditv(0,0,1,0) = 5 + typmes
 181       inditv(0,0,2,0) = 6 + typmes
 182       inditv(0,0,0,1) = 7 + typmes
 183       inditv(0,0,0,2) = 8 + typmes
 184 c
 185 cgn      print *,(volint(1,iaux), iaux = 0 , volint(1,0) )
 186 cgn      print *,(volint(2,iaux), iaux = 0 , volint(2,0) )
 187 cgn      print *,(volint(3,iaux), iaux = 0 , volint(3,0) )
 188 cgn      print *,(volint(4,iaux), iaux = 0 , volint(4,0) )
 189 c
 190 c====
 191 c 2. decompte des elements de volumes voisins
 192 c====
 193 c
 194 #ifdef _DEBUG_HOMARD_
 195       write (ulsort,texte(langue,3)) 'UTVGVA', nompro
 196 #endif
 197       call utvgv1 ( nufade, nufafi,
 198      >              voltri, pypetr,
 199      >              volqua, pypequ,
 200      >              nbtetr, nbhexa, nbpyra, nbpent,
 201      >              trav1a, trav2a,
 202      >              ulsort, langue, codret )
 203 c
 204 c====
 205 c 3. filtrage des elements interdits
 206 c====
 207 #ifdef _DEBUG_HOMARD_
 208       write (ulsort,*) '3. filtrage  ; codret = ', codret
 209 #endif
 210 c
 211       if ( codret.eq.0 ) then
 212 c
 213 c 3.0. ==> decalage dans le tableau face/volumes (trav1a)
 214 c
 215       decafv = 2 * ( nufafi - nufade + 1 )
 216 c
 217 c 3.1. ==> tetraedres
 218 c
 219       if ( volint(1,0).gt.0 ) then
 220 c
 221 #ifdef _DEBUG_HOMARD_
 222       write (ulsort,texte(langue,5)) mess14(langue,3,3), volint(1,0)
 223       write (ulsort,90002) 'Numeros',(volint(1,jaux),jaux=1,volint(1,0))
 224 #endif
 225 c
 226         kaux = 0
 227         do 31 , nument = 1 , nbtetr
 228           letetr = trav1a(nument)
 229           do 311 , jaux = 1 , volint(1,0)
 230             if ( volint(1,jaux).eq.letetr ) then
 231               iaux = nument
 232 #include "tbdim2.h"
 233               trav1a(iaux) = 0
 234               goto 31
 235             endif
 236   311     continue
 237           kaux = kaux + 1
 238    31   continue
 239         nbtevr = min(2,kaux)
 240 c
 241       else
 242 c
 243         nbtevr = nbtetr
 244 c
 245       endif
 246 c
 247 c 3.2. ==> hexaedres
 248 c
 249       if ( volint(2,0).gt.0 ) then
 250 c
 251 #ifdef _DEBUG_HOMARD_
 252       write (ulsort,texte(langue,5)) mess14(langue,3,6), volint(2,0)
 253       write (ulsort,90002) 'Numeros',(volint(2,jaux),jaux=1,volint(2,0))
 254 #endif
 255 c
 256         kaux = 0
 257         do 32 , nument = 1 , nbhexa
 258           lehexa = trav1a(decafv+nument)
 259           do 321 , jaux = 1 , volint(2,0)
 260             if ( volint(2,jaux).eq.lehexa ) then
 261               iaux = decafv+nument
 262 #include "tbdim2.h"
 263               trav1a(iaux) = 0
 264               goto 32
 265             endif
 266   321     continue
 267           kaux = kaux + 1
 268    32   continue
 269         nbhevr = kaux
 270 c
 271       else
 272 c
 273         nbhevr = nbhexa
 274 c
 275       endif
 276 c
 277 c 3.3. ==> pyramides
 278 c
 279       if ( volint(3,0).gt.0 ) then
 280 c
 281 #ifdef _DEBUG_HOMARD_
 282       write (ulsort,texte(langue,5)) mess14(langue,3,5), volint(3,0)
 283       write (ulsort,90002) 'Numeros',(volint(3,jaux),jaux=1,volint(3,0))
 284 #endif
 285 c
 286         kaux = 0
 287         do 33 , nument = 1 , nbpyra
 288           lapyra = trav1a(2*decafv+nument)
 289           do 331 , jaux = 1 , volint(3,0)
 290             if ( volint(3,jaux).eq.lapyra ) then
 291               iaux = 2*decafv+nument
 292 #include "tbdim2.h"
 293               trav1a(iaux) = 0
 294               goto 33
 295             endif
 296   331     continue
 297           kaux = kaux + 1
 298    33   continue
 299         nbpyvr = min(2,kaux)
 300 c
 301       else
 302 c
 303         nbpyvr = nbpyra
 304 c
 305       endif
 306 c
 307 c 3.4. ==> pentaedres
 308 c
 309       if ( volint(4,0).gt.0 ) then
 310 c
 311 #ifdef _DEBUG_HOMARD_
 312       write (ulsort,texte(langue,5)) mess14(langue,3,7), volint(4,0)
 313       write (ulsort,90002) 'Numeros',(volint(4,jaux),jaux=1,volint(4,0))
 314 #endif
 315 c
 316         kaux = 0
 317         do 34 , nument = 1 , nbpent
 318           lepent = trav1a(3*decafv+nument)
 319           do 341 , jaux = 1 , volint(4,0)
 320             if ( volint(4,jaux).eq.lepent ) then
 321               iaux = 3*decafv+nument
 322 #include "tbdim2.h"
 323               trav1a(iaux) = 0
 324               goto 34
 325             endif
 326   341     continue
 327           kaux = kaux + 1
 328    34   continue
 329         nbpevr = min(2,kaux)
 330 c
 331       else
 332 c
 333         nbpevr = nbpent
 334 c
 335       endif
 336 c
 337 c====
 338 c 4. impression
 339 c====
 340 c
 341 c 4.1. ==> tetraedres
 342 c
 343       if ( nbtevr.ne.0 ) then
 344 c
 345 #ifdef _DEBUG_HOMARD_
 346         write (ulsort,texte(langue,7)) mess14(langue,3,3), nbtevr
 347 #endif
 348         iaux = min(2,nbtevr)
 349         write (ulecr,40002) textvo(inditv(iaux,0,0,0))
 350         do 41 , nument = 1 , nbtetr
 351           iaux = nument
 352           letetr = trav1a(iaux)
 353           if ( letetr.gt.0 ) then
 354             etat = mod(hettet(letetr),100)
 355             taux40 = textte(etat)
 356             write (ulecr,46000) letetr, taux40
 357           endif
 358    41   continue
 359       endif
 360 c
 361 c 4.2. ==> hexaedres
 362 c
 363       if ( nbhevr.ne.0 ) then
 364 c
 365 #ifdef _DEBUG_HOMARD_
 366         write (ulsort,texte(langue,7)) mess14(langue,3,6), nbhevr
 367         write (ulsort,texte(langue,7)) mess14(langue,3,6), nbhexa
 368 #endif
 369         iaux = min(2,nbhevr)
 370         write (ulecr,40002) textvo(inditv(0,iaux,0,0))
 371         do 42 , nument = 1 , nbhexa
 372           iaux = decafv+nument
 373           lehexa = trav1a(iaux)
 374           if ( lehexa.gt.0 ) then
 375             etat = mod(hethex(lehexa),1000)
 376             if ( etat.le.10 ) then
 377               taux40 = texthe(etat)
 378               write (ulecr,46000) lehexa, taux40
 379             else
 380               bindec = chbiet(etat)
 381               if ( etat.le.22 ) then
 382                 write (ulecr,46031) lehexa, charde(bindec)(1:3)
 383               elseif ( ( etat.ge.285 ) .and. ( etat.le.290 ) ) then
 384                 taux40 = texthe(etat-244)
 385                 write (ulecr,46000) lehexa, taux40
 386               else
 387                 write (ulecr,46030) lehexa, charde(bindec)(1:27)
 388               endif
 389             endif
 390           endif
 391    42   continue
 392       endif
 393 c
 394 c 4.3. ==> pyramides
 395 c
 396       if ( nbpyvr.ne.0 ) then
 397 c
 398 #ifdef _DEBUG_HOMARD_
 399         write (ulsort,texte(langue,7)) mess14(langue,3,5), nbpyvr
 400 #endif
 401         iaux = min(2,nbpyvr)
 402         write (ulecr,40002) textvo(inditv(0,0,iaux,0))
 403         do 43 , nument = 1 , nbpyra
 404           iaux = 2*decafv+nument
 405           lapyra = trav1a(iaux)
 406           if ( lapyra.gt.0 ) then
 407             etat = mod(hetpyr(lapyra),100)
 408             taux40 = textpy(etat)
 409             write (ulecr,46000) lapyra, taux40
 410           endif
 411    43   continue
 412       endif
 413 c
 414 c 4.4. ==> pentaedres
 415 c
 416       if ( nbpevr.ne.0 ) then
 417 c
 418 #ifdef _DEBUG_HOMARD_
 419         write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpevr
 420 #endif
 421         iaux = min(2,nbpevr)
 422         write (ulecr,40002) textvo(inditv(0,0,0,iaux))
 423         do 44 , nument = 1 , nbpent
 424           iaux = 3*decafv+nument
 425           lepent = trav1a(iaux)
 426           if ( lepent.gt.0 ) then
 427             etat = mod(hetpen(lepent),100)
 428             taux40 = textpe(etat)
 429             write (ulecr,46000) lepent, taux40
 430           endif
 431    44   continue
 432       endif
 433 c
 434       endif
 435 c
 436 c====
 437 c 5. La fin
 438 c====
 439 c
 440       if ( codret.ne.0 ) then
 441 c
 442 #include "envex2.h"
 443 c
 444       write (ulsort,texte(langue,1)) 'Sortie', nompro
 445       write (ulsort,texte(langue,2)) codret
 446 c
 447       endif
 448 c
 449 #ifdef _DEBUG_HOMARD_
 450       write (ulsort,texte(langue,1)) 'Sortie', nompro
 451       call dmflsh (iaux)
 452 #endif
 453 c
 454       end