src/tool/Decision/deisv6.F

   1       subroutine deisv6 ( laface, typfac, lamail, typenh,
   2      >                    hettri, pertri,
   3      >                    hetqua, perqua,
   4      >                    pertet,
   5      >                    hethex, filhex, perhex, fhpyte,
   6      >                    voltri, pypetr,
   7      >                    volqua, pypequ,
   8      >                    nbvote, voiste,
   9      >                    nbvohe, voishe,
  10      >                    nbvopy, voispy,
  11      >                    nbvope, voispe,
  12      >                    ulsort, langue, codret )
  13 c ______________________________________________________________________
  14 c
  15 c                             H O M A R D
  16 c
  17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  18 c
  19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  20 c aupres des huissiers de justice Simart et Lavoir a Clamart
  21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  22 c aupres des huissiers de justice
  23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  24 c
  25 c    HOMARD est une marque deposee d'Electricite de France
  26 c
  27 c Copyright EDF 1996
  28 c Copyright EDF 1998
  29 c Copyright EDF 2002
  30 c Copyright EDF 2020
  31 c ______________________________________________________________________
  32 c
  33 c    traitement des DEcisions - Initialisations - par Saut - Volumes - 6
  34 c                   --          -                     -      -         -
  35 c   Recherche des voisins d'une maille decrite par ses faces
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . laface . e   .   1    . la face en cours d'examen                  .
  41 c . typfac . e   .   1    . type de la face                            .
  42 c .        .     .        . 2 : triangles                              .
  43 c .        .     .        . 4 : quadrangles                            .
  44 c . lamail . e   .   1    . la maille en cours d'examen                .
  45 c . typenh . e   .   1    . type de la maille                          .
  46 c .        .     .        . 3 : tetraedres                             .
  47 c .        .     .        . 5 : pyramides                              .
  48 c .        .     .        . 6 : hexaedres                              .
  49 c .        .     .        . 7 : pentaedres                             .
  50 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  51 c . pertri . e   . nbtrto . pere des triangles                         .
  52 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  53 c . perqua . e   . nbquto . pere des quadrangles                       .
  54 c . pertet . e   . nbteto . pere des tetraedres                        .
  55 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  56 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  57 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  58 c . filhex . e   . nbheto . premier fils des hexaedres                 .
  59 c . perhex . e   . nbheto . pere des hexaedres                         .
  60 c . fhpyte . e   .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide   .
  61 c .        .     .        . fille de l'hexaedre k tel que filhex(k) =-j.
  62 c .        .     .        . fhpyte(2,j) = numero du 1er tetraedre      .
  63 c .        .     .        . fils de l'hexaedre k tel que filhex(k) = -j.
  64 c . voltri . es  .2*nbtrto. numeros des 2 volumes par triangle         .
  65 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  66 c .        .     .        .   0 : pas de voisin                        .
  67 c .        .     .        . j>0 : tetraedre j                          .
  68 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  69 c . pypetr . e   .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
  70 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  71 c .        .     .        . pypetr(2,j) = numero du pentaedre voisin   .
  72 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  73 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  74 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  75 c .        .     .        .   0 : pas de voisin                        .
  76 c .        .     .        . j>0 : hexaedre j                           .
  77 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  78 c . pypequ . e   .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
  79 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  80 c .        .     .        . pypequ(2,j) = numero du pentaedre voisin   .
  81 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  82 c . nbvote . es  .    1   . nombre de voisins de type tetraedre        .
  83 c . voiste . es  . nbvote . les voisins de type tetraedre              .
  84 c . nbvohe . es  .    1   . nombre de voisins de type hexaedre         .
  85 c . voishe . es  . nbvohe . les voisins de type hexaedre               .
  86 c . nbvopy . es  .    1   . nombre de voisins de type pyramide         .
  87 c . voispy . es  . nbvopy . les voisins de type pyramide               .
  88 c . nbvope . es  .    1   . nombre de voisins de type pentaedre        .
  89 c . voispe . es  . nbvope . les voisins de type pentaedre              .
  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 .        .     .        . 2 : probleme dans le traitement            .
  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 = 'DEISV6' )
 109 c
 110 #include "nblang.h"
 111 c
 112 c 0.2. ==> communs
 113 c
 114 #include "envex1.h"
 115 c
 116 #include "impr02.h"
 117 #include "nombtr.h"
 118 #include "nombqu.h"
 119 #include "nombte.h"
 120 #include "nombhe.h"
 121 #include "hexcf0.h"
 122 c
 123 c 0.3. ==> arguments
 124 c
 125       integer laface, typfac
 126       integer lamail, typenh
 127       integer hettri(nbtrto), pertri(nbtrto)
 128       integer hetqua(nbquto), perqua(nbquto)
 129       integer pertet(nbteto)
 130       integer hethex(nbheto), filhex(nbheto), perhex(nbheto)
 131       integer fhpyte(2,nbheco)
 132       integer voltri(2,nbtrto), pypetr(2,*)
 133       integer volqua(2,nbquto), pypequ(2,*)
 134 c
 135       integer nbvote, voiste(*)
 136       integer nbvohe, voishe(*)
 137       integer nbvopy, voispy(*)
 138       integer nbvope, voispe(*)
 139 c
 140       integer ulsort, langue, codret
 141 c
 142 c 0.4. ==> variables locales
 143 c
 144       integer iaux, jaux, kaux, laux
 145       integer etat, bindec, lamere, lepere, levois
 146       integer nbfipy, filspy
 147       integer nbfite, filste
 148       integer nbfihe, filshe
 149 c
 150       integer nbmess
 151       parameter (nbmess = 10 )
 152       character*80 texte(nblang,nbmess)
 153 c ______________________________________________________________________
 154 c
 155 c====
 156 c 1. initialisation
 157 c====
 158 c
 159 c 1.1. ==> Les messages
 160 c
 161 #include "impr01.h"
 162 #include "impr03.h"
 163 c
 164 #ifdef _DEBUG_HOMARD_
 165       write (ulsort,texte(langue,1)) 'Entree', nompro
 166       call dmflsh (iaux)
 167 #endif
 168 c
 169       texte(1,4) = '(''. Voisins de la maille'',i10,'' ('',a,'')'')'
 170 c
 171       texte(2,4) =
 172      > '(''. Neighbourgs of the mesh #'',i10,'' ('',a,'')'')'
 173 c
 174       codret = 0
 175 c
 176 #ifdef _DEBUG_HOMARD_
 177       write (ulsort,texte(langue,4)) lamail, mess14(langue,1,typenh)
 178 #endif
 179 c
 180 c====
 181 c 2. On parcourt tous les voisins de la face
 182 c====
 183 #ifdef _DEBUG_HOMARD_
 184       write (ulsort,*) '2. parcours voisins face ; codret = ', codret
 185 #endif
 186 c
 187 c 2.1. ==> L'etat de la face
 188 c
 189       if ( typfac.eq.2 ) then
 190         etat = mod(hettri(laface),10)
 191       else
 192         etat = mod(hetqua(laface),100)
 193       endif
 194 cgn      write (ulsort,90002) '.. etat', etat
 195 c
 196 c 2.2. ==> traitement pour une face non coupee
 197 c
 198       if ( etat.eq.0 ) then
 199 c
 200         do 221 , iaux = 1 , 2
 201 cgn      write (ulsort,90002) '.... voisin de rang', iaux
 202 c
 203 c 2.2.1. ==> Cas de la face triangulaire
 204 c
 205           if ( typfac.eq.2 ) then
 206 c
 207             jaux = voltri(iaux,laface)
 208 c
 209 c 2.2.1.1. ==> Il existe un voisin tetraedre
 210             if ( jaux.gt.0 ) then
 211               nbvote = nbvote + 1
 212               voiste(nbvote) = jaux
 213 c 2.2.1.2. ==> Il existe un voisin pyramide ou pentaedre
 214             elseif ( jaux.lt.0 ) then
 215               jaux = -jaux
 216               if ( pypetr(1,jaux).ne.0 ) then
 217                 nbvopy = nbvopy + 1
 218                 voispy(nbvopy) = pypetr(1,jaux)
 219               endif
 220               if ( pypetr(2,jaux).ne.0 ) then
 221                 nbvope = nbvope + 1
 222                 voispe(nbvope) = pypetr(2,jaux)
 223               endif
 224 c 2.2.1.3. ==> Il n'existe pas de voisin
 225             else
 226               lamere = pertri(laface)
 227               if ( lamere.gt.0 ) then
 228                 if ( voltri(2,lamere).ne.0 ) then
 229                   do 2211 , kaux = 1 , 2
 230                     levois = voltri(kaux,lamere)
 231                     if ( levois.ne.pertet(lamail) ) then
 232 c
 233                   write(ulsort,*) 'A PROGRAMMER quand on aura'
 234                   write(ulsort,*) 'la conformite des pentaedres'
 235                   codret = 2211
 236 c
 237                     endif
 238  2211             continue
 239                 endif
 240               elseif ( lamere.lt.0 ) then
 241                 if ( volqua(2,-lamere).ne.0 ) then
 242                   do 2212 , kaux = 1 , 2
 243                     levois = volqua(kaux,-lamere)
 244                     if ( levois.ne.pertet(lamail) ) then
 245 c
 246                   write(ulsort,*) 'A PROGRAMMER quand on aura'
 247                   write(ulsort,*) 'la conformite des pentaedres'
 248                   codret = 2212
 249 c
 250                     endif
 251  2212             continue
 252                 endif
 253               endif
 254             endif
 255 c
 256 c 2.2.2. ==> Cas de la face quadrangulaire
 257 c
 258           else
 259 c
 260             jaux = volqua(iaux,laface)
 261 cgn      write (ulsort,90002) '.... jaux', jaux
 262 c 2.2.2.1. ==> Il existe un voisin hexaedre
 263             if ( jaux.gt.0 ) then
 264               nbvohe = nbvohe + 1
 265               voishe(nbvohe) = jaux
 266 c 2.2.2.2. ==> Il existe un voisin pyramide ou pentaedre
 267             elseif ( jaux.lt.0 ) then
 268               jaux = -jaux
 269               if ( pypequ(1,jaux).ne.0 ) then
 270                 nbvopy = nbvopy + 1
 271                 voispy(nbvopy) = pypequ(1,jaux)
 272               endif
 273               if ( pypequ(2,jaux).ne.0 ) then
 274                 nbvope = nbvope + 1
 275                 voispe(nbvope) = pypequ(2,jaux)
 276               endif
 277 c 2.2.2.3. ==> Il n'existe pas de voisin
 278 c              Soit c'est un bord et il n'y a rien a faire.
 279 c              Soit c'est que la maille du niveau precedent a ete
 280 c              coupee par conformite et les fils sont decrites par
 281 c              aretes : le voisinage n'est pas reconstitue. Dans ce
 282 c              cas, on stocke tous les fils.
 283 c              Remarque : la face mere ne peut avoir 2 voisins que
 284 c              dans le cas d'hexaedres voisins. A completer quand
 285 c              on aura programme le raffinement conforme complet
 286 c              des pentaedres
 287             else
 288               lamere = perqua(laface)
 289 cgn      write (ulsort,90002) 'lamere', lamere
 290               if ( lamere.gt.0 ) then
 291                 if ( volqua(2,lamere).ne.0 ) then
 292                   do 2221 , kaux = 1 , 2
 293                     if ( volqua(kaux,lamere).ne.perhex(lamail) ) then
 294 c
 295                       lepere = volqua(kaux,lamere)
 296                       etat = mod(hethex(lepere),1000)
 297                       bindec = chbiet(etat)
 298                       nbfihe = chnhe(bindec)
 299                       nbfipy = chnpy(bindec)
 300                       nbfite = chnte(bindec)
 301                       filshe = filhex(lepere)
 302                       if ( nbfihe.gt.0 ) then
 303                         do 22211 , laux = 0 , nbfihe-1
 304                           nbvohe = nbvohe + 1
 305                           voishe(nbvohe) = filshe + iaux
 306 22211                   continue
 307                       endif
 308                       if ( nbfipy.gt.0 ) then
 309                         filspy = fhpyte(1,-filshe)
 310                         do 22212 , laux = 0 , nbfipy-1
 311                           nbvopy = nbvopy + 1
 312                           voispy(nbvopy) = filspy + iaux
 313 22212                   continue
 314                       endif
 315                       if ( nbfite.gt.0 ) then
 316                         filste = fhpyte(2,-filshe)
 317                         do 22213 , laux = 0 , nbfite-1
 318                           nbvote = nbvote + 1
 319                           voiste(nbvote) = filste + iaux
 320 22213                   continue
 321                       endif
 322 c
 323                     endif
 324  2221             continue
 325                 endif
 326               endif
 327             endif
 328 c
 329           endif
 330 c
 331   221   continue
 332 c
 333       endif
 334 c
 335 c====
 336 c 3. la fin
 337 c====
 338 c
 339       if ( codret.ne.0 ) then
 340 c
 341 #include "envex2.h"
 342 c
 343       write (ulsort,texte(langue,1)) 'Sortie', nompro
 344       write (ulsort,texte(langue,2)) codret
 345 c
 346       endif
 347 c
 348 #ifdef _DEBUG_HOMARD_
 349       write (ulsort,texte(langue,1)) 'Sortie', nompro
 350       call dmflsh (iaux)
 351 #endif
 352 c
 353       end