src/tool/Utilitaire/utvgv2.F

   1       subroutine utvgv2 ( nbarto, nbtrto, nbquto,
   2      >                    nbteto, nbtecf, nbteca,
   3      >                    nbheto, nbhecf, nbheca,
   4      >                    nbpyto, nbpycf, nbpyca,
   5      >                    nbpeto, nbpecf, nbpeca,
   6      >                    aretri,
   7      >                    arequa,
   8      >                    tritet, cotrte, aretet,
   9      >                    quahex, coquhe, arehex,
  10      >                    facpyr, cofapy, arepyr,
  11      >                    facpen, cofape, arepen,
  12      >                    nbtear, pttear,
  13      >                    nbhear, pthear,
  14      >                    nbpyar, ptpyar,
  15      >                    nbpear, ptpear,
  16      >                    ulsort, langue, codret )
  17 c ______________________________________________________________________
  18 c
  19 c                             H O M A R D
  20 c
  21 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  22 c
  23 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  24 c aupres des huissiers de justice Simart et Lavoir a Clamart
  25 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  26 c aupres des huissiers de justice
  27 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  28 c
  29 c    HOMARD est une marque deposee d'Electricite de France
  30 c
  31 c Copyright EDF 1996
  32 c Copyright EDF 1998
  33 c Copyright EDF 2002
  34 c Copyright EDF 2020
  35 c ______________________________________________________________________
  36 c
  37 c     UTilitaire : VoisinaGes Volumes / aretes - phase 2
  38 c     --           -      -   -                        -
  39 c ______________________________________________________________________
  40 c
  41 c  determine le nombre de volumes voisins de chaque arete, par categorie
  42 c  En sortie :
  43 c    pttear(0) = 0
  44 c    pttear(i) = position du dernier voisin de l'arete i-1
  45 c              = nombre cumule de voisins pour les (i-1) 1eres aretes
  46 c ______________________________________________________________________
  47 c .        .     .        .                                            .
  48 c .  nom   . e/s . taille .           description                      .
  49 c .____________________________________________________________________.
  50 c . nbarto . e   .  1     . nombre total d'aretes                      .
  51 c . nbtrto . e   .  1     . nombre total de triangles                  .
  52 c . nbquto . e   .  1     . nombre total de quadrangles                .
  53 c . nbteto . e   .  1     . nombre de tetraedres total                 .
  54 c . nbtecf . e   .  1     . nombre total de tetraedres decrits par face.
  55 c . nbteca . e   .  1     . nombre total de tetras decrits par aretes  .
  56 c . nbheto . e   .   1    . nombre d'hexaedres total                   .
  57 c . nbhecf . e   .  1     . nombre d'hexaedres decrits par faces       .
  58 c . nbheca . e   .  1     . nombre d'hexaedres decrits par aretes      .
  59 c . nbpyto . e   .   1    . nombre de pyramides total                  .
  60 c . nbpycf . e   .  1     . nombre total de pyramides decrits par faces.
  61 c . nbpyca . e   .  1     . nombre total de pyras decrits par aretes   .
  62 c . nbpeto . e   .   1    . nombre de pentaedres total                 .
  63 c . nbpecf . e   .  1     . nombre total de pentas decrits par faces   .
  64 c . nbpeca . e   .  1     . nombre total de pentas decrits par aretes  .
  65 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  66 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  67 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  68 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  69 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  70 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  71 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  72 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  73 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  74 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  75 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  76 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  77 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  78 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  79 c . nbtear .  s  .    1   . nombre de tetraedres voisins d'aretes      .
  80 c . pttear .  s  .0:nbarto. nombre de tetraedres voisins par aretes    .
  81 c . nbhear .  s  .    1   . nombre d'hexaedres voisins d'aretes        .
  82 c . pthear .  s  .0:nbarto. nombre d'hexaedres voisins par aretes      .
  83 c . nbpyar .  s  .    1   . nombre de pyramides voisines d'aretes      .
  84 c . ptpyar .  s  .0:nbarto. nombre de pyramides voisines par aretes    .
  85 c . nbpear .  s  .    1   . nombre de pentaedres voisins d'aretes      .
  86 c . ptpear .  s  .0:nbarto. nombre de pentaedres voisins par aretes    .
  87 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  88 c . langue . e   .    1   . langue des messages                        .
  89 c .        .     .        . 1 : francais, 2 : anglais                  .
  90 c . codret . es  .    1   . code de retour des modules                 .
  91 c .        .     .        . 0 : pas de probleme                        .
  92 c .        .     .        . non nul : probleme                         .
  93 c ______________________________________________________________________
  94 c
  95 c====
  96 c 0. declarations et dimensionnement
  97 c====
  98 c
  99 c 0.1. ==> generalites
 100 c
 101       implicit none
 102       save
 103 c
 104       character*6 nompro
 105       parameter ( nompro = 'UTVGV2' )
 106 c
 107 #include "nblang.h"
 108 c
 109 c 0.2. ==> communs
 110 c
 111 #include "envex1.h"
 112 #include "impr02.h"
 113 c
 114 c 0.3. ==> arguments
 115 c
 116       integer nbarto, nbtrto, nbquto
 117       integer nbteto, nbtecf, nbteca
 118       integer nbheto, nbhecf, nbheca
 119       integer nbpyto, nbpycf, nbpyca
 120       integer nbpeto, nbpecf, nbpeca
 121 c
 122       integer aretri(nbtrto,3)
 123       integer arequa(nbquto,4)
 124       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 125       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 126       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 127       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 128 c
 129       integer nbtear, pttear(0:nbarto)
 130       integer nbhear, pthear(0:nbarto)
 131       integer nbpyar, ptpyar(0:nbarto)
 132       integer nbpear, ptpear(0:nbarto)
 133 c
 134       integer ulsort, langue, codret
 135 c
 136 c 0.4. ==> variables locales
 137 c
 138       integer iaux
 139       integer letetr, lehexa, lapyra, lepent
 140       integer listar(12)
 141 c
 142       integer nbmess
 143       parameter ( nbmess = 10 )
 144       character*80 texte(nblang,nbmess)
 145 c ______________________________________________________________________
 146 c
 147 c====
 148 c 1. initialisation
 149 c====
 150 c
 151 #include "impr01.h"
 152 c
 153 #ifdef _DEBUG_HOMARD_
 154       write (ulsort,texte(langue,1)) 'Entree', nompro
 155       call dmflsh (iaux)
 156 #endif
 157 c
 158 #include "impr03.h"
 159 c
 160 #ifdef _DEBUG_HOMARD_
 161       write (ulsort,90002) 'nbarto', nbarto
 162       write (ulsort,90002) 'nbtrto', nbtrto
 163       write (ulsort,90002) 'nbquto', nbquto
 164       write (ulsort,90002) 'nbteto, nbtecf', nbteto, nbtecf
 165       write (ulsort,90002) 'nbheto, nbhecf', nbheto, nbhecf
 166       write (ulsort,90002) 'nbpyto, nbpycf', nbpyto, nbpycf
 167       write (ulsort,90002) 'nbpeto, nbpecf', nbpeto, nbpecf
 168 #endif
 169 c
 170 c====
 171 c 2. decompte des tetraedres voisins d'aretes
 172 c====
 173 c
 174       if ( nbteto.gt.0 ) then
 175 c
 176         do 21 , iaux = 0 , nbarto
 177           pttear(iaux) = 0
 178   21    continue
 179 c
 180         do 22 , letetr = 1 , nbteto
 181 c
 182           if ( letetr.le.nbtecf ) then
 183 c
 184             call utarte ( letetr,
 185      >                    nbtrto, nbtecf,
 186      >                    aretri, tritet, cotrte,
 187      >                    listar )
 188 c
 189           else
 190 c
 191             do 221 , iaux = 1 , 6
 192               listar(iaux) = aretet(letetr-nbtecf,iaux)
 193   221       continue
 194 c
 195           endif
 196 c
 197           do 222 , iaux = 1 , 6
 198             pttear(listar(iaux)) = pttear(listar(iaux)) + 1
 199   222     continue
 200 c
 201    22   continue
 202 c
 203         do 23 , iaux = 1 , nbarto
 204           pttear(iaux) = pttear(iaux-1) + pttear(iaux)
 205   23    continue
 206         nbtear = pttear(nbarto)
 207         do 24 , iaux = nbarto , 1 , -1
 208           pttear(iaux) = pttear(iaux-1)
 209   24    continue
 210 c
 211       endif
 212 c
 213 c====
 214 c 3. decompte des hexaedres voisins d'aretes
 215 c====
 216 c
 217       if ( nbheto.gt.0 ) then
 218 c
 219         do 31 , iaux = 0 , nbarto
 220           pthear(iaux) = 0
 221   31    continue
 222 c
 223         do 32 , lehexa = 1 , nbheto
 224 c
 225           if ( lehexa.le.nbhecf ) then
 226 c
 227             call utarhe ( lehexa,
 228      >                    nbquto, nbhecf,
 229      >                    arequa, quahex, coquhe,
 230      >                    listar )
 231 c
 232           else
 233 c
 234             do 321 , iaux = 1 , 12
 235               listar(iaux) = arehex(lehexa-nbhecf,iaux)
 236   321       continue
 237 c
 238           endif
 239 c
 240           do 322 , iaux = 1 , 12
 241             pthear(listar(iaux)) = pthear(listar(iaux)) + 1
 242   322     continue
 243 c
 244    32   continue
 245 c
 246         do 33 , iaux = 1 , nbarto
 247           pthear(iaux) = pthear(iaux-1) + pthear(iaux)
 248   33    continue
 249         nbhear = pthear(nbarto)
 250         do 34 , iaux = nbarto , 1 , -1
 251           pthear(iaux) = pthear(iaux-1)
 252   34    continue
 253 c
 254       endif
 255 c
 256 c====
 257 c 4. decompte des pyramides voisines d'aretes
 258 c====
 259 c
 260       if ( nbpyto.gt.0 ) then
 261 c
 262         do 41 , iaux = 0 , nbarto
 263           ptpyar(iaux) = 0
 264   41    continue
 265 c
 266         do 42 , lapyra = 1 , nbpyto
 267 c
 268           if ( lapyra.le.nbpycf ) then
 269 c
 270             call utarpy ( lapyra,
 271      >                    nbtrto, nbpycf,
 272      >                    aretri, facpyr, cofapy,
 273      >                    listar )
 274 c
 275           else
 276 c
 277             do 421 , iaux = 1 , 8
 278               listar(iaux) = arepyr(lapyra-nbpycf,iaux)
 279   421       continue
 280 c
 281           endif
 282 c
 283           do 422 , iaux = 1 , 8
 284             ptpyar(listar(iaux)) = ptpyar(listar(iaux)) + 1
 285   422     continue
 286 c
 287    42   continue
 288 c
 289         do 43 , iaux = 1 , nbarto
 290           ptpyar(iaux) = ptpyar(iaux-1) + ptpyar(iaux)
 291   43    continue
 292         nbpyar = ptpyar(nbarto)
 293         do 44 , iaux = nbarto , 1 , -1
 294           ptpyar(iaux) = ptpyar(iaux-1)
 295   44    continue
 296 c
 297       endif
 298 c
 299 c====
 300 c 5. decompte des pentaedres voisins d'aretes
 301 c====
 302 c
 303       if ( nbpeto.gt.0 ) then
 304 c
 305         do 51 , iaux = 0 , nbarto
 306           ptpear(iaux) = 0
 307   51    continue
 308 c
 309         do 52 , lepent = 1 , nbpeto
 310 c
 311           if ( lepent.le.nbpecf ) then
 312 c
 313             call utarpe ( lepent,
 314      >                    nbquto, nbpecf,
 315      >                    arequa, facpen, cofape,
 316      >                    listar )
 317 c
 318           else
 319 c
 320             do 521 , iaux = 1 , 9
 321               listar(iaux) = arepen(lepent-nbpecf,iaux)
 322   521       continue
 323 c
 324           endif
 325 c
 326           do 522 , iaux = 1 , 9
 327             ptpear(listar(iaux)) = ptpear(listar(iaux)) + 1
 328   522     continue
 329 c
 330    52   continue
 331 c
 332         do 53 , iaux = 1 , nbarto
 333           ptpear(iaux) = ptpear(iaux-1) + ptpear(iaux)
 334   53    continue
 335         nbpear = ptpear(nbarto)
 336         do 54 , iaux = nbarto , 1 , -1
 337           ptpear(iaux) = ptpear(iaux-1)
 338   54    continue
 339 c
 340       endif
 341 c
 342 #ifdef _DEBUG_HOMARD_
 343       write (ulsort,90002) 'nbtear', nbtear
 344       write (ulsort,90002) 'nbhear', nbhear
 345       write (ulsort,90002) 'nbpyar', nbpyar
 346       write (ulsort,90002) 'nbpear', nbpear
 347 #endif
 348 c
 349 c====
 350 c 6. La fin
 351 c====
 352 c
 353       if ( codret.ne.0 ) then
 354 c
 355 #include "envex2.h"
 356 c
 357       write (ulsort,texte(langue,1)) 'Sortie', nompro
 358       write (ulsort,texte(langue,2)) codret
 359 c
 360       endif
 361 c
 362 #ifdef _DEBUG_HOMARD_
 363       write (ulsort,texte(langue,1)) 'Sortie', nompro
 364       call dmflsh (iaux)
 365 #endif
 366 c
 367       end