src/tool/Decision/deisv8.F

   1       subroutine deisv8 ( lehexa,
   2      >                    filqua,
   3      >                    hethex, quahex,
   4      >                    filhex, fhpyte,
   5      >                    volqua,
   6      >                    nbfite, nbvote, voiste,
   7      >                    nbfihe, nbvohe, voishe,
   8      >                    nbfipy, nbvopy, voispy,
   9      >                    ulsort, langue, codret )
  10 c ______________________________________________________________________
  11 c
  12 c                             H O M A R D
  13 c
  14 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  15 c
  16 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  17 c aupres des huissiers de justice Simart et Lavoir a Clamart
  18 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  19 c aupres des huissiers de justice
  20 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  21 c
  22 c    HOMARD est une marque deposee d'Electricite de France
  23 c
  24 c Copyright EDF 1996
  25 c Copyright EDF 1998
  26 c Copyright EDF 2002
  27 c Copyright EDF 2020
  28 c ______________________________________________________________________
  29 c
  30 c    traitement des DEcisions - Initialisations - par Saut - Volumes - 8
  31 c                   --          -                     -      -         -
  32 c   Pour un hexaedre coupe par conformite et dont les fils sont decrits
  33 c   par aretes :
  34 c   - etablissement de la liste des fils par type de maille
  35 c   - ajout des fils des voisins de l'hexaedre
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . lehexa . e   .   1    . l'hexaedre en cours d'examen               .
  41 c . filqua . e   . nbquto . fils des quadrangles                       .
  42 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  43 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  44 c . filhex . e   . nbheto . premier fils des hexaedres                 .
  45 c . fhpyte . e   .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide   .
  46 c .        .     .        . fille de l'hexaedre k tel que filhex(k) =-j.
  47 c .        .     .        . fhpyte(2,j) = numero du 1er tetraedre      .
  48 c .        .     .        . fils de l'hexaedre k tel que filhex(k) = -j.
  49 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  50 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  51 c .        .     .        .   0 : pas de voisin                        .
  52 c .        .     .        . j>0 : hexaedre j                           .
  53 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  54 c . nbfite .  s  .  1     . nombre de fils de type tetraedre           .
  55 c . nbvote .  s  .    1   . nombre de voisins de type tetraedre        .
  56 c . voiste .  s  . nbvote . les voisins de type tetraedre              .
  57 c . nbfihe .  s  .  1     . nombre de fils de type hexaedre            .
  58 c . nbvohe .  s  .    1   . nombre de voisins de type hexaedre         .
  59 c . voishe .  s  . nbvohe . les voisins de type hexaedre               .
  60 c . nbfipy .  s  .  1     . nombre de fils de type pyramide            .
  61 c . nbvopy .  s  .    1   . nombre de voisins de type pyramide         .
  62 c . voispy .  s  . nbvopy . les voisins de type pyramide               .
  63 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  64 c . langue . e   .    1   . langue des messages                        .
  65 c .        .     .        . 1 : francais, 2 : anglais                  .
  66 c . codret .  s  .    1   . code de retour des modules                 .
  67 c .        .     .        . 0 : pas de probleme                        .
  68 c .        .     .        . 2 : probleme dans le traitement            .
  69 c ______________________________________________________________________
  70 c
  71 c====
  72 c 0. declarations et dimensionnement
  73 c====
  74 c
  75 c 0.1. ==> generalites
  76 c
  77       implicit none
  78       save
  79 c
  80       character*6 nompro
  81       parameter ( nompro = 'DEISV8' )
  82 c
  83 #include "nblang.h"
  84 c
  85 c 0.2. ==> communs
  86 c
  87 #include "envex1.h"
  88 c
  89 #include "impr02.h"
  90 #include "nombqu.h"
  91 #include "nombhe.h"
  92 c
  93 c 0.3. ==> arguments
  94 c
  95       integer lehexa
  96       integer filqua(nbquto)
  97       integer hethex(nbheto), filhex(nbheto)
  98       integer quahex(nbhecf,6)
  99       integer fhpyte(2,nbheco)
 100       integer volqua(2,nbquto)
 101 c
 102       integer nbfite, nbvote, voiste(*)
 103       integer nbfihe, nbvohe, voishe(*)
 104       integer nbfipy, nbvopy, voispy(*)
 105 c
 106       integer ulsort, langue, codret
 107 c
 108 c 0.4. ==> variables locales
 109 c
 110       integer iaux, jaux, kaux, laux
 111       integer etat
 112       integer laface, levois
 113       integer lafafi, levofi
 114       integer filste
 115       integer filshe
 116       integer filspy
 117       integer nbfitf, filstf
 118       integer nbfihf, filshf
 119       integer nbfipf, filspf
 120 c
 121       integer nbmess
 122       parameter (nbmess = 10 )
 123       character*80 texte(nblang,nbmess)
 124 c ______________________________________________________________________
 125 c
 126 c====
 127 c 1. initialisation
 128 c====
 129 c
 130 c 1.1. ==> Les messages
 131 c
 132 #include "impr01.h"
 133 #include "impr03.h"
 134 c
 135 #ifdef _DEBUG_HOMARD_
 136       write (ulsort,texte(langue,1)) 'Entree', nompro
 137       call dmflsh (iaux)
 138 #endif
 139 c
 140       texte(1,4) = '(''. Voisins de l''''hexaedre'',i10,'')'
 141       texte(1,5) = '(''... Face '',i10,'')'
 142 c
 143       texte(2,4) = '(''. Neighbourgs of the mesh #'',i10,'')'
 144       texte(2,5) = '(''... Face '',i10,'')'
 145 c
 146       codret = 0
 147 c
 148 #ifdef _DEBUG_HOMARD_
 149       write (ulsort,texte(langue,4)) lehexa
 150 #endif
 151 c
 152 c====
 153 c 2. Recuperation des fils
 154 c====
 155 #ifdef _DEBUG_HOMARD_
 156       write (ulsort,*) '2. parcours voisins face ; codret = ', codret
 157 #endif
 158 c
 159       call utfihe ( lehexa,
 160      >              hethex, filhex, fhpyte,
 161      >              nbfite, filste,
 162      >              nbfihe, filshe,
 163      >              nbfipy, filspy )
 164 c
 165       nbvote = nbfite
 166       do 21 , iaux = 1 ,  nbfite
 167         voiste(iaux) = filste + iaux - 1
 168    21 continue
 169 c
 170       nbvohe = nbfihe
 171       do 22 , iaux = 1 ,  nbfihe
 172         voishe(iaux) = filshe + iaux - 1
 173    22 continue
 174 c
 175       nbvopy = nbfipy
 176       do 23 , iaux = 1 ,  nbfipy
 177         voispy(iaux) = filspy + iaux - 1
 178    23 continue
 179 c
 180 c====
 181 c 3. On passe en revue les voisins par face de l'hexaedre
 182 c====
 183 c
 184       do 30 , iaux = 1 , 6
 185 c
 186         laface = quahex(lehexa,iaux)
 187 #ifdef _DEBUG_HOMARD_
 188       write (ulsort,texte(langue,5)) laface
 189 #endif
 190 c
 191         do 31 , jaux = 1 , 2
 192 c
 193           levois = volqua(jaux,laface)
 194 c
 195 c 3.1. ==> Le jaux-eme est un hexaedre
 196 c
 197           if ( levois.gt.0 ) then
 198 c
 199             if ( levois.ne.lehexa ) then
 200 c
 201             etat = mod(hethex(levois),1000)
 202 c 3.1.1. ==> Le voisin est actif : on le stocke
 203             if ( etat.eq.0 ) then
 204               nbvohe = nbvohe + 1
 205               voishe(nbvohe) = levois
 206 c 3.1.2. ==> Le voisin est coupe en 8 avec eventuellement des
 207 c            petits-fils :
 208 c            On parcourt les 4 filles de laface : elles n'ont qu'un
 209 c            voisin qui est un hexaedre fils de levois.
 210 c            . Si ce fils est actif, on le stocke
 211 c            . Sinon, c'est qu'il est coupe par conformite et
 212 c              on stocke ses enfants.
 213             elseif ( etat.eq.8 .or. etat.eq.9 ) then
 214               lafafi = filqua(laface)
 215               do 312 , kaux = 1 , 4
 216                 levofi = volqua(1,lafafi+kaux-1)
 217                 if ( mod(hethex(levofi),1000).eq.0 ) then
 218                   nbvohe = nbvohe + 1
 219                   voishe(nbvohe) = levofi
 220                 else
 221                   call utfihe ( levofi,
 222      >                          hethex, filhex, fhpyte,
 223      >                          nbfitf, filstf,
 224      >                          nbfihf, filshf,
 225      >                          nbfipf, filspf )
 226                   do 3121 , laux = 1 ,  nbfitf
 227                     nbvote = nbvote + 1
 228                     voiste(nbvote) = filstf + laux - 1
 229  3121             continue
 230                   do 3122 , laux = 1 ,  nbfihf
 231                     nbvohe = nbvohe + 1
 232                     voishe(nbvohe) = filshf + laux - 1
 233  3122             continue
 234                   do 3123 , laux = 1 ,  nbfipf
 235                     nbvopy = nbvopy + 1
 236                     voispy(nbvopy) = filspf + laux - 1
 237  3123             continue
 238                 endif
 239   312         continue
 240 c
 241 c 3.1.3. ==> Le voisin est coupepar conformite :
 242 c              on stocke ses enfants.
 243             else
 244               call utfihe ( levois,
 245      >                      hethex, filhex, fhpyte,
 246      >                      nbfitf, filstf,
 247      >                      nbfihf, filshf,
 248      >                      nbfipf, filspf )
 249               do 3131 , laux = 1 ,  nbfitf
 250                 nbvote = nbvote + 1
 251                 voiste(nbvote) = filstf + laux - 1
 252  3131         continue
 253               do 3132 , laux = 1 ,  nbfihf
 254                 nbvohe = nbvohe + 1
 255                 voishe(nbvohe) = filshf + laux - 1
 256  3132         continue
 257               do 3133 , laux = 1 ,  nbfipf
 258                 nbvopy = nbvopy + 1
 259                 voispy(nbvopy) = filspf + laux - 1
 260  3133         continue
 261 c
 262             endif
 263 c
 264             endif
 265 c
 266 c 3.2. ==> Le jaux-eme est un pentaedre ou une pyramide : pas encore
 267 c
 268           elseif ( levois.lt.0 ) then
 269             codret = 3829
 270           endif
 271 c
 272    31   continue
 273 c
 274    30 continue
 275 c
 276 c
 277 #ifdef _DEBUG_HOMARD_
 278       write (ulsort,90002) 'hexaedre', lehexa
 279       write (ulsort,90002) 'fils/voisins tetr', nbfite, nbvote
 280       if ( nbvote.gt.0 ) then
 281       write (ulsort,91010) (voiste(iaux),iaux=1,nbvote)
 282       endif
 283       write (ulsort,90002) 'fils/voisins hexa', nbfihe, nbvohe
 284       if ( nbvohe.gt.0 ) then
 285       write (ulsort,91010) (voishe(iaux),iaux=1,nbvohe)
 286       endif
 287       write (ulsort,90002) 'fils/voisins pyra', nbfipy, nbvopy
 288       if ( nbvopy.gt.0 ) then
 289       write (ulsort,91010) (voispy(iaux),iaux=1,nbvopy)
 290       endif
 291 #endif
 292 c====
 293 c 4. la fin
 294 c====
 295 c
 296       if ( codret.ne.0 ) then
 297 c
 298 #include "envex2.h"
 299 c
 300       write (ulsort,texte(langue,1)) 'Sortie', nompro
 301       write (ulsort,texte(langue,2)) codret
 302 c
 303       endif
 304 c
 305 #ifdef _DEBUG_HOMARD_
 306       write (ulsort,texte(langue,1)) 'Sortie', nompro
 307       call dmflsh (iaux)
 308 #endif
 309 c
 310       end