src/tool/Utilitaire/utvgv1.F

   1       subroutine utvgv1 ( nufade, nufafi,
   2      >                    voltri, pypetr,
   3      >                    volqua, pypequ,
   4      >                    nbtetr, nbhexa, nbpyra, nbpent,
   5      >                    trav1a, trav2a,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c     UTilitaire : VoisinaGes Volumes / aretes - phase 1
  28 c     --           -      -   -                        -
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . nufade . e   .   1    . numero initial de la liste des faces       .
  34 c . nufafi . e   .   1    . numero final de la liste des faces         .
  35 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  36 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  37 c .        .     .        .   0 : pas de voisin                        .
  38 c .        .     .        . j>0 : tetraedre j                          .
  39 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  40 c . pypetr . e   .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
  41 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  42 c .        .     .        . pypetr(2,j) = numero du pentaedre voisin   .
  43 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  44 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  45 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  46 c .        .     .        .   0 : pas de voisin                        .
  47 c .        .     .        . j>0 : hexaedre j                           .
  48 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  49 c . pypequ . e   .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
  50 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  51 c .        .     .        . pypequ(2,j) = numero du pentaedre voisin   .
  52 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  53 c . nbtetr .  s  .   1    . nombre de tetraedres voisins               .
  54 c . nbhexa .  s  .   1    . nombre d'hexaedres voisins                 .
  55 c . nbpyra .  s  .   1    . nombre de pyramides voisines               .
  56 c . nbpent .  s  .   1    . nombre de pentaedres voisins               .
  57 c . trav1a .  s  .   *    . liste des voisins                          .
  58 c . trav2a . a   .   *    . liste des faces a examiner                 .
  59 c .        .     .        . . numero positif si triangle               .
  60 c .        .     .        . . numero negatif si quadrangle             .
  61 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  62 c . langue . e   .    1   . langue des messages                        .
  63 c .        .     .        . 1 : francais, 2 : anglais                  .
  64 c . codret . es  .    1   . code de retour des modules                 .
  65 c .        .     .        . 0 : pas de probleme                        .
  66 c .        .     .        . non nul : probleme                         .
  67 c ______________________________________________________________________
  68 c
  69 c====
  70 c 0. declarations et dimensionnement
  71 c====
  72 c
  73 c 0.1. ==> generalites
  74 c
  75       implicit none
  76       save
  77 c
  78       character*6 nompro
  79       parameter ( nompro = 'UTVGV1' )
  80 c
  81 #include "nblang.h"
  82 #include "tbdim0.h"
  83 c
  84 c 0.2. ==> communs
  85 c
  86 #include "envex1.h"
  87 #include "impr02.h"
  88 c
  89 #include "nombtr.h"
  90 #include "nombqu.h"
  91 #include "nombte.h"
  92 #include "nombhe.h"
  93 #include "nombpy.h"
  94 #include "nombpe.h"
  95 c
  96 c 0.3. ==> arguments
  97 c
  98       integer nufade, nufafi
  99       integer nbtetr, nbhexa, nbpyra, nbpent
 100       integer voltri(2,nbtrto), pypetr(2,*)
 101       integer volqua(2,nbquto), pypequ(2,*)
 102 c
 103       integer trav1a(tbdim), trav2a(*)
 104 c
 105       integer ulsort, langue, codret
 106 c
 107 c 0.4. ==> variables locales
 108 c
 109       integer iaux, jaux, kaux
 110       integer cote, laface, nuface
 111       integer decafv
 112 c
 113       integer nbmess
 114       parameter ( nbmess = 10 )
 115       character*80 texte(nblang,nbmess)
 116 c ______________________________________________________________________
 117 c
 118 c====
 119 c 1. initialisation
 120 c====
 121 c
 122 c 1.1. ==> messages
 123 c
 124 #include "impr01.h"
 125 c
 126 #ifdef _DEBUG_HOMARD_
 127       write (ulsort,texte(langue,1)) 'Entree', nompro
 128       call dmflsh (iaux)
 129 #endif
 130 c
 131       texte(1,4) = '(''Examen de'',i10,'' face(s).'')'
 132       texte(1,5) = '(i10,'' voisins de type '',a)'
 133 c
 134       texte(2,4) = '(''Examination of'',i10,'' face(s).'')'
 135       texte(2,5) = '(i10,'' neighbours '',a,''type'')'
 136 c
 137 #include "impr03.h"
 138 c
 139 #ifdef _DEBUG_HOMARD_
 140       write (ulsort,texte(langue,4)) nufafi-nufade+1
 141       write (ulsort,90002) 'Numeros',(trav2a(jaux),jaux=nufade,nufafi)
 142 #endif
 143 #include "tbdim1.h"
 144 c
 145 c====
 146 c 2. decompte des elements de volumes voisins
 147 c====
 148 c
 149       nbtetr = 0
 150       nbhexa = 0
 151       nbpyra = 0
 152       nbpent = 0
 153 c
 154       if ( nbteto.gt.0 .or. nbheto.gt.0 .or.
 155      >     nbpyto.gt.0 .or. nbpeto.gt.0 ) then
 156 c
 157       decafv = 2 * ( nufafi - nufade + 1 )
 158 c
 159       do 20 , nuface = nufade, nufafi
 160 c
 161         laface = trav2a(nuface)
 162 c
 163 c 2.1. ==> La face est un triangle
 164 c
 165         if ( laface.gt.0 ) then
 166 #ifdef _DEBUG_HOMARD_
 167         write (ulsort,90002) mess14(langue,1,2), laface
 168 #endif
 169 c
 170           do 21 , cote = 1 , 2
 171 c
 172             jaux = voltri(cote,laface)
 173 c
 174 c 2.1.1. ==> voisinage par un tetraedre
 175 c
 176             if ( jaux.gt.0 ) then
 177 c
 178               do 211 , kaux = 1 , nbtetr
 179                 if ( trav1a(kaux).eq.jaux ) then
 180                   goto 21
 181                 endif
 182   211         continue
 183               nbtetr = nbtetr + 1
 184               iaux = nbtetr
 185 #include "tbdim2.h"
 186               trav1a(iaux) = jaux
 187 c
 188             elseif ( jaux.lt.0 ) then
 189 c
 190 c 2.1.2. ==> voisinage par une pyramide
 191 c
 192               if ( pypetr(1,-jaux).gt.0 ) then
 193                 do 212 , kaux = 1 , nbpyra
 194                   if ( trav1a(2*decafv+kaux).eq.
 195      >                 pypetr(1,-jaux) ) then
 196                     goto 21
 197                   endif
 198   212           continue
 199                 nbpyra = nbpyra + 1
 200                 iaux = 2*decafv+nbpyra
 201 #include "tbdim2.h"
 202                 trav1a(iaux) = pypetr(1,-jaux)
 203               endif
 204 c
 205 c 2.1.3. ==> voisinage par un pentaedre
 206 c
 207               if ( pypetr(2,-jaux).gt.0 ) then
 208                 do 213 , kaux = 1 , nbpent
 209                   if ( trav1a(3*decafv+kaux).eq.
 210      >                 pypetr(2,-jaux) ) then
 211                     goto 21
 212                   endif
 213   213           continue
 214                 nbpent = nbpent + 1
 215                 iaux = 3*decafv+nbpent
 216 #include "tbdim2.h"
 217                 trav1a(iaux) = pypetr(2,-jaux)
 218               endif
 219 c
 220             endif
 221 c
 222    21     continue
 223 c
 224 c 2.2. ==> La face est un quadrangle
 225 c
 226         elseif ( laface.lt.0 ) then
 227 c
 228 #ifdef _DEBUG_HOMARD_
 229         write (ulsort,90002) mess14(langue,1,4), -laface
 230 #endif
 231 c
 232           do 22 , cote = 1 , 2
 233 c
 234             jaux = volqua(cote,-laface)
 235 c
 236 c 2.2.1. ==> voisinage par un hexaedre
 237 c
 238             if ( jaux.gt.0 ) then
 239 c
 240               do 221 , kaux = 1 , nbhexa
 241                 if ( trav1a(decafv+kaux).eq.jaux ) then
 242                   goto 22
 243                 endif
 244   221         continue
 245               nbhexa = nbhexa + 1
 246               iaux = decafv+nbhexa
 247 #include "tbdim2.h"
 248               trav1a(iaux) = jaux
 249 c
 250             elseif ( jaux.lt.0 ) then
 251 c
 252 c 2.2.2. ==> voisinage par une pyramide
 253 c
 254               if ( pypequ(1,-jaux).gt.0 ) then
 255                 do 222 , kaux = 1 , nbpyra
 256                   if ( trav1a(2*decafv+kaux).eq.
 257      >                 pypequ(1,-jaux) ) then
 258                     goto 22
 259                   endif
 260   222           continue
 261                 nbpyra = nbpyra + 1
 262                 iaux = 2*decafv+nbpyra
 263 #include "tbdim2.h"
 264                 trav1a(iaux) = pypequ(1,-jaux)
 265               endif
 266 c
 267 c 2.2.3. ==> voisinage par un pentaedre
 268 c
 269               if ( pypequ(2,-jaux).gt.0 ) then
 270                 do 223 , kaux = 1 , nbpent
 271                   if ( trav1a(3*decafv+kaux).eq.
 272      >                 pypequ(2,-jaux) ) then
 273                     goto 22
 274                   endif
 275   223           continue
 276                 nbpent = nbpent + 1
 277                 iaux = 3*decafv+nbpent
 278 #include "tbdim2.h"
 279                 trav1a(iaux) = pypequ(2,-jaux)
 280               endif
 281 c
 282             endif
 283 c
 284    22     continue
 285 c
 286         endif
 287 c
 288    20 continue
 289 c
 290       endif
 291 c
 292 #ifdef _DEBUG_HOMARD_
 293       write (ulsort,texte(langue,5)) nbtetr, mess14(langue,1,3)
 294       write (ulsort,texte(langue,5)) nbhexa, mess14(langue,1,6)
 295       write (ulsort,texte(langue,5)) nbpyra, mess14(langue,1,5)
 296       write (ulsort,texte(langue,5)) nbpent, mess14(langue,1,7)
 297 #endif
 298 c
 299 c====
 300 c 3. La fin
 301 c====
 302 c
 303       if ( codret.ne.0 ) then
 304 c
 305 #include "envex2.h"
 306 c
 307       write (ulsort,texte(langue,1)) 'Sortie', nompro
 308       write (ulsort,texte(langue,2)) codret
 309 c
 310       endif
 311 c
 312 #ifdef _DEBUG_HOMARD_
 313       write (ulsort,texte(langue,1)) 'Sortie', nompro
 314       call dmflsh (iaux)
 315 #endif
 316 c
 317       end