src/tool/Utilitaire/uthequ.F

   1       subroutine uthequ ( decisi,
   2      >                    nbquto, nbheto, nbhecf, nbpyto, nbpycf,
   3      >                    quahex, hethex, filhex,
   4      >                    fhpyte,
   5      >                    facpyr,
   6      >                    volqua,
   7      >                    ulsort, langue, codret )
   8 c
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    UTilitaire - HExaedres - QUadrangles
  30 c    --           --          --
  31 c ______________________________________________________________________
  32 c
  33 c but : etablit le tableau volqua a partir de son reciproque, quahex
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . decisi . e   .   1    . pilotage des voisins des quadrangles :     .
  39 c .        .     .        . 1 : on construit la table.                 .
  40 c .        .     .        . 2 : on construit la table et on controle   .
  41 c .        .     .        . a. qu'il n'y a pas de hexaedre doubles     .
  42 c .        .     .        . b. qu'un quadrangle n'appartient pas a plus.
  43 c .        .     .        .    de 2 hexaedres                          .
  44 c . nbquto . e   .   1    . nombre de quadrangles total                .
  45 c . nbheto . e   .   1    . nombre d'hexaedres total                   .
  46 c . nbhecf . e   .   1    . nombre d'hexaedres decrits par faces       .
  47 c . nbpyto . e   .   1    . nombre de pyramides total                  .
  48 c . nbpycf . e   .   1    . nombre de pyramides decrites par faces     .
  49 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  50 c . hethex . e   . nbheto . historique des etats des hexaedres         .
  51 c . filhex . e   . nbheto . premier fils des hexaedres                 .
  52 c . fhpyte . e   .2*nbhedc. fhpyte(1,j) = numero de la 1ere pyramide   .
  53 c .        .     .        . fille de l'hexaedre k tel que filhex(k) =-j.
  54 c .        .     .        . fhpyte(2,j) = numero du 1er tetraedre      .
  55 c .        .     .        . fils de l'hexaedre k tel que filhex(k) = -j.
  56 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  57 c . volqua .  s  .nbquto*2. numeros des 2 volumes par quadrangle       .
  58 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  59 c .        .     .        .   0 : pas de voisin                        .
  60 c .        .     .        . j>0 : hexaedre j                           .
  61 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  62 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  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 . es  .    1   . code de retour des modules                 .
  67 c .        .     .        . 0 : pas de probleme                        .
  68 c .        .     .        . 1 : probleme dans le controle              .
  69 c .        .     .        . 3 : probleme de hexaedres doubles          .
  70 c ______________________________________________________________________
  71 c
  72 c====
  73 c 0. declarations et dimensionnement
  74 c====
  75 c
  76 c 0.1. ==> generalites
  77 c
  78       implicit none
  79       save
  80 c
  81       character*6 nompro
  82       parameter ( nompro = 'UTHEQU' )
  83 c
  84 #include "nblang.h"
  85 c
  86 c 0.2. ==> communs
  87 c
  88 #include "envex1.h"
  89 #include "hexcf0.h"
  90 c
  91 c 0.3. ==> arguments
  92 c
  93       integer nbquto, nbheto, nbhecf, nbpyto, nbpycf
  94       integer filhex(nbheto), hethex(nbheto), quahex(nbhecf,6)
  95       integer fhpyte(2,*)
  96       integer facpyr(nbpycf,5)
  97       integer volqua(2,nbquto)
  98       integer decisi
  99 c
 100       integer ulsort, langue, codret
 101 c
 102 c 0.4. ==> variables locales
 103 c
 104       integer iaux, jaux, kaux
 105       integer codre1, codre2
 106       integer etat, bindec, nbfipy
 107       integer fils
 108       integer lehexa
 109       integer lequad, quad(6), quabis(6), quadcl(6), quabcl(6)
 110 #ifdef _DEBUG_HOMARD_
 111       integer glop
 112 #endif
 113 c
 114       integer nbmess
 115       parameter ( nbmess = 10 )
 116       character*80 texte(nblang,nbmess)
 117 c
 118 c 0.5. ==> initialisations
 119 c ______________________________________________________________________
 120 c
 121 c====
 122 c 1. messages
 123 c====
 124 c
 125 #include "impr01.h"
 126 c
 127 #ifdef _DEBUG_HOMARD_
 128       write (ulsort,texte(langue,1)) 'Entree', nompro
 129       call dmflsh (iaux)
 130 #endif
 131 c
 132       texte(1,4) =
 133      > '(/,''Le quadrangle'',i10,'' a plus de deux voisins ?'')'
 134       texte(1,5) = '(''Hexaedres :'',3i10,/)'
 135       texte(1,6) =
 136      > '(/,''Les deux hexaedres suivants sont identiques.'')'
 137       texte(1,7) =
 138      > '(''Quadrangles du hexaedre numero :'',i10,'' : '',4i10)'
 139 c
 140       texte(2,4) =
 141      > '(/,''Quadrangle'',i10,'' has more than 2 neighbours ?'')'
 142       texte(2,5) = '(''Tetraedra :'',3i10,/)'
 143       texte(2,6) = '(/,''The following two tetraedra are the same.'')'
 144       texte(2,7) ='(''Quadrangles of hexahedron #'',i10,'' : '',4i10)'
 145 c
 146 #include "impr03.h"
 147 c
 148       codret = 0
 149 c
 150 #ifdef _DEBUG_HOMARD_
 151       write(ulsort,90002) 'nbquto', nbquto
 152       write(ulsort,90002) 'nbheto', nbheto
 153       write(ulsort,90002) 'nbhecf', nbhecf
 154       write(ulsort,90002) 'nbpyto', nbpyto
 155       write(ulsort,90002) 'nbpycf', nbpycf
 156 #endif
 157 c
 158 c====
 159 c 2. liste des hexaedres s'appuyant sur chaque quadrangle
 160 c    attention : a priori, un quadrangle borde 0, 1 ou 2 hexaedres
 161 c====
 162 c
 163 c 2. ==> on regarde tous les hexaedres decrits par faces
 164 c
 165       do 20 , lehexa = 1 , nbhecf
 166 c
 167 c 2.1. ==> les quadrangles du hexaedre en cours d'examen
 168 c
 169         quad(1) = quahex(lehexa,1)
 170         quad(2) = quahex(lehexa,2)
 171         quad(3) = quahex(lehexa,3)
 172         quad(4) = quahex(lehexa,4)
 173         quad(5) = quahex(lehexa,5)
 174         quad(6) = quahex(lehexa,6)
 175 #ifdef _DEBUG_HOMARD_
 176         if ( lehexa.eq.-437 .or. lehexa.le.-438 ) then
 177              write(ulsort,90015) 'quads de hexa', lehexa,' :', quad
 178              glop = 1
 179         else
 180           glop = 0
 181         endif
 182 #endif
 183 c
 184 c 2.2. ==> quand un hexaedre est decoupe pour la mise en
 185 c          conformite, certains de ses quadrangles sont des bords de
 186 c          l'hexaedre et de ses fils.
 187 c          La convention HOMARD veut que l'on ne memorise que le fils
 188 c          dans les voisins du quadrangle.
 189 c          on va alors annuler le numero du quadrangle pour ne rien
 190 c          archiver maintenant.
 191 c
 192         etat = mod(hethex(lehexa),1000)
 193 #ifdef _DEBUG_HOMARD_
 194         if ( glop.gt.0 ) then
 195           write(ulsort,90015) 'etat de hexa', lehexa,' :',etat
 196         endif
 197 #endif
 198 c
 199         if ( etat.ge.11 ) then
 200 C
 201           bindec = chbiet(etat)
 202           nbfipy = chnpy(bindec)
 203 #ifdef _DEBUG_HOMARD_
 204         if ( glop.gt.0 ) then
 205           write(ulsort,90002) 'bindec, nbfipy', bindec, nbfipy
 206           write(ulsort,90015) 'fils de ', lehexa,' :', filhex(lehexa)
 207         endif
 208 #endif
 209 c
 210           if ( nbfipy.gt.0 ) then
 211 c
 212             if ( filhex(lehexa).lt.0 ) then
 213 c
 214               iaux = -filhex(lehexa)
 215               fils = fhpyte(1,iaux)
 216 #ifdef _DEBUG_HOMARD_
 217         if ( glop.gt.0 ) then
 218        write(ulsort,90002) 'fils, nbpycf', fils, nbpycf
 219         endif
 220 #endif
 221 c
 222               if ( fils.le.nbpycf ) then
 223 c
 224                 do 22 , jaux = 1 , nbfipy
 225                   do 221 , lequad = 1 , 6
 226                     if ( quad(lequad).eq.facpyr(fils,5) ) then
 227                       quad(lequad) = 0
 228                     endif
 229   221             continue
 230                   fils = fils + 1
 231    22           continue
 232 c
 233               endif
 234 #ifdef _DEBUG_HOMARD_
 235         if ( glop.gt.0 ) then
 236            write(ulsort,90015) 'quads de hexa', lehexa,' :', quad
 237         endif
 238 #endif
 239 c
 240             endif
 241 c
 242           endif
 243 c
 244         endif
 245 c
 246 c 2.3. ==> pour chacun des 6 quadrangles encore a traiter
 247 c
 248         do 23 , lequad = 1 , 6
 249 c
 250           if ( quad(lequad).gt.0 ) then
 251 c
 252 c 2.3.1. ==> aucun voisin n'existe : on met l'hexaedre courant
 253 c            comme premier voisin
 254 c
 255           if ( volqua(1,quad(lequad)).eq.0 ) then
 256 c
 257             volqua(1,quad(lequad)) = lehexa
 258 c
 259           else
 260 c
 261 c 2.3.2. ==> il existe un premier voisin
 262 c
 263 c 2.3.2.1. ==> en cas de controle :
 264 c
 265             if ( decisi.eq.2 ) then
 266 c
 267 c 2.3.2.1.1. ==> on verifie que le second hexaedre n'est pas identique
 268 c                au premier. Pour cela, on trie les tableaux des
 269 c                quadrangles par numero de quadrangles croissant et
 270 c                on compare.
 271 c
 272               if ( volqua(2,quad(lequad)).eq.0 ) then
 273 c
 274                 if ( volqua(1,quad(lequad)).gt.0 ) then
 275 c
 276                   quabis(1) = quahex(volqua(1,quad(lequad)),1)
 277                   quabis(2) = quahex(volqua(1,quad(lequad)),2)
 278                   quabis(3) = quahex(volqua(1,quad(lequad)),3)
 279                   quabis(4) = quahex(volqua(1,quad(lequad)),4)
 280                   quabis(5) = quahex(volqua(1,quad(lequad)),5)
 281                   quabis(6) = quahex(volqua(1,quad(lequad)),6)
 282 c
 283                   call uttrii ( quadcl, jaux, kaux,
 284      >                          6, quad,
 285      >                          ulsort, langue, codre1 )
 286 c
 287                   call uttrii ( quabcl, jaux, kaux,
 288      >                          6, quabis,
 289      >                          ulsort, langue, codre2 )
 290 c
 291                   if ( codre1.eq.0 .and. codre2.eq.0 ) then
 292                     if ( quad(quadcl(1)).eq.quabis(quabcl(1)) .and.
 293      >                   quad(quadcl(2)).eq.quabis(quabcl(2)) .and.
 294      >                   quad(quadcl(3)).eq.quabis(quabcl(3)) .and.
 295      >                   quad(quadcl(4)).eq.quabis(quabcl(4)) .and.
 296      >                   quad(quadcl(5)).eq.quabis(quabcl(5)) .and.
 297      >                   quad(quadcl(6)).eq.quabis(quabcl(6)) ) then
 298                       write(ulsort,texte(langue,6))
 299                       write(ulsort,texte(langue,7)) lehexa, quad
 300                       write(ulsort,texte(langue,7))
 301      >                                    volqua(1,quad(lequad)), quabis
 302                       codret = 3
 303                     endif
 304                   else
 305                     codret = 1
 306                   endif
 307 c
 308                   endif
 309 c
 310 c 2.3.2.1.2. ==> il y a deja un second volume comme voisin de ce
 311 c                quadrangle !
 312 c
 313               else
 314 c
 315                 write(ulsort,texte(langue,4)) quad(lequad)
 316                 write(ulsort,texte(langue,5)) volqua(1,quad(lequad)),
 317      >                                        volqua(2,quad(lequad)),
 318      >                                        lehexa
 319                 codret = 3
 320 c
 321               endif
 322 c
 323             endif
 324 c
 325 c 2.3.2.2. ==> il existe un premier voisin : on met l'hexaedre
 326 c              courant comme second voisin
 327 c
 328             volqua(2,quad(lequad)) = lehexa
 329 c
 330           endif
 331 c
 332           endif
 333 c
 334    23   continue
 335 c
 336    20 continue
 337 c
 338 c====
 339 c 3. la fin
 340 c====
 341 c
 342       if ( codret.ne.0 ) then
 343 c
 344 #include "envex2.h"
 345 c
 346       write (ulsort,texte(langue,1)) 'Sortie', nompro
 347       write (ulsort,texte(langue,2)) codret
 348 c
 349       endif
 350 c
 351 #ifdef _DEBUG_HOMARD_
 352       write (ulsort,texte(langue,1)) 'Sortie', nompro
 353       call dmflsh (iaux)
 354 #endif
 355 c
 356       end