src/tool/Utilitaire/utvgv3.F

   1       subroutine utvgv3 ( 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, tatear,
  13      >                    nbhear, pthear, tahear,
  14      >                    nbpyar, ptpyar, tapyar,
  15      >                    nbpear, ptpear, tapear,
  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 3
  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(i) = position du dernier voisin de l'arete i
  44 c              = nombre cumule de voisins pour les i 1eres aretes
  45 c ______________________________________________________________________
  46 c .        .     .        .                                            .
  47 c .  nom   . e/s . taille .           description                      .
  48 c .____________________________________________________________________.
  49 c . nbarto . e   .  1     . nombre total d'aretes                      .
  50 c . nbtrto . e   .  1     . nombre total de triangles                  .
  51 c . nbquto . e   .  1     . nombre total de quadrangles                .
  52 c . nbteto . e   .  1     . nombre de tetraedres total                 .
  53 c . nbtecf . e   .  1     . nombre total de tetraedres decrits par face.
  54 c . nbteca . e   .  1     . nombre total de tetras decrits par aretes  .
  55 c . nbheto . e   .   1    . nombre d'hexaedres total                   .
  56 c . nbhecf . e   .  1     . nombre d'hexaedres decrits par faces       .
  57 c . nbheca . e   .  1     . nombre d'hexaedres decrits par aretes      .
  58 c . nbpyto . e   .   1    . nombre de pyramides total                  .
  59 c . nbpycf . e   .  1     . nombre total de pyramides decrits par faces.
  60 c . nbpyca . e   .  1     . nombre total de pyras decrits par aretes   .
  61 c . nbpeto . e   .   1    . nombre de pentaedres total                 .
  62 c . nbpecf . e   .  1     . nombre total de pentas decrits par faces   .
  63 c . nbpeca . e   .  1     . nombre total de pentas decrits par aretes  .
  64 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  65 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  66 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  67 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  68 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  69 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  70 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  71 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  72 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  73 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  74 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  75 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  76 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  77 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  78 c . nbtear . e   .    1   . nombre de tetraedres voisins d'aretes      .
  79 c . pttear . es  .0:nbarto. nombre de tetraedres voisins par aretes    .
  80 c . tatear .  s  . nbtear . tetraedres voisins par aretes              .
  81 c . nbhear . e   .    1   . nombre d'hexaedres voisins d'aretes        .
  82 c . pthear . es  .0:nbarto. nombre d'hexaedres voisins par aretes      .
  83 c . tahear .  s  . nbhear . hexaedres voisins par aretes               .
  84 c . nbpyar . e   .    1   . nombre de pyramides voisines d'aretes      .
  85 c . ptpyar . es  .0:nbarto. nombre de pyramides voisines par aretes    .
  86 c . tapyar .  s  . nbpyar . pyramides voisines par aretes              .
  87 c . nbpear . e   .    1   . nombre de pentaedres voisins d'aretes      .
  88 c . ptpear . es  .0:nbarto. nombre de pentaedres voisins par aretes    .
  89 c . tapear .  s  . nbpear . pentaedres voisins par aretes              .
  90 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  91 c . langue . e   .    1   . langue des messages                        .
  92 c .        .     .        . 1 : francais, 2 : anglais                  .
  93 c . codret . es  .    1   . code de retour des modules                 .
  94 c .        .     .        . 0 : pas de probleme                        .
  95 c .        .     .        . non nul : probleme                         .
  96 c ______________________________________________________________________
  97 c
  98 c====
  99 c 0. declarations et dimensionnement
 100 c====
 101 c
 102 c 0.1. ==> generalites
 103 c
 104       implicit none
 105       save
 106 c
 107       character*6 nompro
 108       parameter ( nompro = 'UTVGV3' )
 109 c
 110 #include "nblang.h"
 111 c
 112 c 0.2. ==> communs
 113 c
 114 #include "envex1.h"
 115 #include "impr02.h"
 116 c
 117 c 0.3. ==> arguments
 118 c
 119       integer nbarto, nbtrto, nbquto
 120       integer nbteto, nbtecf, nbteca
 121       integer nbheto, nbhecf, nbheca
 122       integer nbpyto, nbpycf, nbpyca
 123       integer nbpeto, nbpecf, nbpeca
 124 c
 125       integer aretri(nbtrto,3)
 126       integer arequa(nbquto,4)
 127       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 128       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 129       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 130       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 131 c
 132       integer nbtear, pttear(0:nbarto), tatear(nbtear)
 133       integer nbhear, pthear(0:nbarto), tahear(nbhear)
 134       integer nbpyar, ptpyar(0:nbarto), tapyar(nbpyar)
 135       integer nbpear, ptpear(0:nbarto), tapear(nbpear)
 136 c
 137       integer ulsort, langue, codret
 138 c
 139 c 0.4. ==> variables locales
 140 c
 141       integer iaux, jaux
 142       integer letetr, lehexa, lapyra, lepent
 143       integer listar(12)
 144 c
 145       integer nbmess
 146       parameter ( nbmess = 10 )
 147       character*80 texte(nblang,nbmess)
 148 c ______________________________________________________________________
 149 c
 150 c====
 151 c 1. initialisation
 152 c====
 153 c
 154 #include "impr01.h"
 155 c
 156 #ifdef _DEBUG_HOMARD_
 157       write (ulsort,texte(langue,1)) 'Entree', nompro
 158       call dmflsh (iaux)
 159 #endif
 160 c
 161 #include "impr03.h"
 162 c
 163 #ifdef _DEBUG_HOMARD_
 164       write (ulsort,90002) 'nbtear', nbtear
 165       write (ulsort,90002) 'nbhear', nbhear
 166       write (ulsort,90002) 'nbpyar', nbpyar
 167       write (ulsort,90002) 'nbpear', nbpear
 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 , letetr = 1 , nbteto
 177 c
 178           if ( letetr.le.nbtecf ) then
 179 c
 180             call utarte ( letetr,
 181      >                    nbtrto, nbtecf,
 182      >                    aretri, tritet, cotrte,
 183      >                    listar )
 184 c
 185           else
 186 c
 187             do 211 , iaux = 1 , 6
 188               listar(iaux) = aretet(letetr-nbtecf,iaux)
 189   211       continue
 190 c
 191           endif
 192 c
 193           do 212 , iaux = 1 , 6
 194             jaux = listar(iaux)
 195             pttear(jaux) = pttear(jaux) + 1
 196             tatear(pttear(jaux)) = letetr
 197   212     continue
 198 c
 199    21   continue
 200 c
 201       endif
 202 c
 203 c====
 204 c 3. decompte des hexaedres voisins d'aretes
 205 c====
 206 c
 207       if ( nbheto.gt.0 ) then
 208 c
 209         do 31 , lehexa = 1 , nbheto
 210 c
 211           if ( lehexa.le.nbhecf ) then
 212 c
 213             call utarhe ( lehexa,
 214      >                    nbquto, nbhecf,
 215      >                    arequa, quahex, coquhe,
 216      >                    listar )
 217 c
 218           else
 219 c
 220             do 311 , iaux = 1 , 12
 221               listar(iaux) = arehex(lehexa-nbhecf,iaux)
 222   311       continue
 223 c
 224           endif
 225 c
 226           do 312 , iaux = 1 , 12
 227             jaux = listar(iaux)
 228             pthear(jaux) = pthear(jaux) + 1
 229             tahear(pthear(jaux)) = lehexa
 230   312     continue
 231 c
 232    31   continue
 233 c
 234       endif
 235 c
 236 c====
 237 c 4. decompte des pyramides voisines d'aretes
 238 c====
 239 c
 240       if ( nbpyto.gt.0 ) then
 241 c
 242         do 41 , lapyra = 1 , nbpyto
 243 c
 244           if ( lapyra.le.nbpycf ) then
 245 c
 246             call utarpy ( lapyra,
 247      >                    nbtrto, nbpycf,
 248      >                    aretri, facpyr, cofapy,
 249      >                    listar )
 250 c
 251           else
 252 c
 253             do 411 , iaux = 1 , 8
 254               listar(iaux) = arepyr(lapyra-nbpycf,iaux)
 255   411       continue
 256 c
 257           endif
 258 c
 259           do 412 , iaux = 1 , 8
 260             jaux = listar(iaux)
 261             ptpyar(jaux) = ptpyar(jaux) + 1
 262             tapyar(ptpyar(jaux)) = lapyra
 263   412     continue
 264 c
 265    41   continue
 266 c
 267       endif
 268 c
 269 c====
 270 c 5. decompte des pentaedres voisins d'aretes
 271 c====
 272 c
 273       if ( nbpeto.gt.0 ) then
 274 c
 275         do 51 , lepent = 1 , nbpeto
 276 c
 277           if ( lepent.le.nbpecf ) then
 278 c
 279             call utarpe ( lepent,
 280      >                    nbquto, nbpecf,
 281      >                    arequa, facpen, cofape,
 282      >                    listar )
 283 c
 284           else
 285 c
 286             do 511 , iaux = 1 , 9
 287               listar(iaux) = arepen(lepent-nbpecf,iaux)
 288   511       continue
 289 c
 290           endif
 291 c
 292           do 512 , iaux = 1 , 9
 293             jaux = listar(iaux)
 294             ptpear(jaux) = ptpear(jaux) + 1
 295             tapear(ptpear(jaux)) = lepent
 296   512     continue
 297 c
 298    51   continue
 299 c
 300       endif
 301 c
 302 c====
 303 c 6. La fin
 304 c====
 305 c
 306       if ( codret.ne.0 ) then
 307 c
 308 #include "envex2.h"
 309 c
 310       write (ulsort,texte(langue,1)) 'Sortie', nompro
 311       write (ulsort,texte(langue,2)) codret
 312 c
 313       endif
 314 c
 315 #ifdef _DEBUG_HOMARD_
 316       write (ulsort,texte(langue,1)) 'Sortie', nompro
 317       call dmflsh (iaux)
 318 #endif
 319 c
 320       end