src/tool/Decision/derco8.F

   1       subroutine derco8 ( niveau,
   2      >                    decare, decfac,
   3      >                    hetare,
   4      >                    hettri, aretri, pertri, nivtri,
   5      >                    voltri,
   6      >                    hetqua, arequa, perqua, nivqua,
   7      >                    volqua,
   8      >                    hettet, tritet,
   9      >                    hethex, quahex,
  10      >                    ulsort, langue, codret )
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c
  31 c traitement des DEcisions - Raffinement : COntamination - option 8
  32 c                --          -             --                     -
  33 c Complement sur la regle des ecarts de niveau pour du non-conforme
  34 c a 1 noeud pendant par arete
  35 c Cas ou les non-conformites sur les faces sont uniquement dans un
  36 c rapport de 1 a 4
  37 c Point de depart : un volume dont au moins une des faces est coupee,
  38 c et au moins une ne l'est pas. On a donc une non conformite entre cet
  39 c hexaedre et son voisin.
  40 c Situation : une des faces filles de la face coupee est a couper, peu
  41 c importe le reste.
  42 c Il faut s'assurer que le volume sera coupe pour eviter que le rapport
  43 c soit > 1/4.
  44 c Methode : on repere le voisin de la mere de la fille a couper qui
  45 c est actif (il y en a au plus 1). On impose a ce voisin que toutes
  46 c ses faces soient decoupees.
  47 c Attention : il faut sauter les faces du bord exterieur car le probleme
  48 c             de non conformite ne se pose pas
  49 c ______________________________________________________________________
  50 c .        .     .        .                                            .
  51 c .  nom   . e/s . taille .           description                      .
  52 c .____________________________________________________________________.
  53 c . niveau . e   .    1   . niveau en cours d'examen                   .
  54 c . decare . es  . nbarto . decisions des aretes                       .
  55 c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
  56 c .        .     . :nbtrto.                                            .
  57 c . merare . e   . nbarto . mere des aretes                            .
  58 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  59 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  60 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  61 c . aretri . e   . nbtrto . numeros des 3 aretes des triangles         .
  62 c . pertri . e   . nbtrto . pere des triangles                         .
  63 c . nivtri . e   . nbtrto . niveau des triangles                       .
  64 c . voltri . e   .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 . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  70 c . arequa . e   . nbquto . numeros des 4 aretes des quadrangles       .
  71 c . perqua . e   . nbquto . pere des quadrangles                       .
  72 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  73 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  74 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  75 c . langue . e   .    1   . langue des messages                        .
  76 c .        .     .        . 1 : francais, 2 : anglais                  .
  77 c . codret . es  .    1   . code de retour des modules                 .
  78 c .        .     .        . 0 : pas de probleme                        .
  79 c ______________________________________________________________________
  80 c
  81 c====
  82 c 0. declarations et dimensionnement
  83 c====
  84 c
  85 c 0.1. ==> generalites
  86 c
  87       implicit none
  88       save
  89 c
  90       character*6 nompro
  91       parameter ( nompro = 'DERCO8' )
  92 c
  93 #include "nblang.h"
  94 c
  95 c 0.2. ==> communs
  96 c
  97 #include "envex1.h"
  98 #include "nombar.h"
  99 #include "nombtr.h"
 100 #include "nombqu.h"
 101 #include "nombte.h"
 102 #include "nombhe.h"
 103 c
 104 c 0.3. ==> arguments
 105 c
 106       integer niveau
 107       integer decare(0:nbarto)
 108       integer decfac(-nbquto:nbtrto)
 109       integer hetare(nbarto)
 110       integer hettri(nbtrto), aretri(nbtrto,3)
 111       integer pertri(nbtrto), nivtri(nbtrto)
 112       integer voltri(2,nbtrto)
 113       integer hetqua(nbquto), arequa(nbquto,4)
 114       integer perqua(nbquto), nivqua(nbquto)
 115       integer volqua(2,nbquto)
 116       integer hettet(nbteto), tritet(nbtecf,4)
 117       integer hethex(nbheto), quahex(nbhecf,6)
 118 c
 119       integer ulsort, langue, codret
 120 c
 121 c 0.4. ==> variables locales
 122 c
 123       integer laface, lehexa, letetr
 124       integer facdeb, facfin
 125       integer iaux, jaux
 126       integer afaire
 127       integer jarelo, jarete, iface
 128       integer merefa
 129 #ifdef _DEBUG_HOMARD_
 130       integer glop
 131 #endif
 132 c
 133       integer nbmess
 134       parameter ( nbmess = 30 )
 135       character*80 texte(nblang,nbmess)
 136 c
 137 c 0.5. ==> initialisations
 138 c ______________________________________________________________________
 139 c
 140 c====
 141 c 1. initialisations
 142 c====
 143 c
 144 #include "impr01.h"
 145 c
 146 #ifdef _DEBUG_HOMARD_
 147       write (ulsort,texte(langue,1)) 'Entree', nompro
 148       call dmflsh (iaux)
 149 #endif
 150 c
 151 #ifdef _DEBUG_HOMARD_
 152 #include "impr03.h"
 153 #endif
 154 c
 155 #include "derco1.h"
 156 c
 157 #ifdef _DEBUG_HOMARD_
 158       write (ulsort,texte(langue,12)) niveau
 159 #endif
 160 c
 161       codret = 0
 162 c
 163       if ( nbheto.gt.0 ) then
 164         facdeb = -nbquto
 165       else
 166         facdeb = 0
 167       endif
 168 c
 169       if ( nbteto.gt.0 ) then
 170         facfin = 0
 171       else
 172         facfin = nbtrto
 173       endif
 174 cgn      write (ulsort,*) facdeb, facfin
 175 c
 176 c====
 177 c 2. Complements sur la regle des ecarts de niveau
 178 c====
 179 c
 180       do 2 , laface = facdeb , facfin
 181 cgn        print *,'entree de ',nompro,', ',laface,' :',decfac(laface)
 182 #ifdef _DEBUG_HOMARD_
 183           if ( laface.eq.-215996 .or.
 184      >         laface.eq.-215996  ) then
 185             glop=1
 186           else
 187             glop=0
 188           endif
 189           if ( glop.eq.1 ) then
 190           if ( nivqua(-laface).eq.niveau ) then
 191         write (ulsort,*) ' ===================='
 192         write (ulsort,*) ' quadrangle : ',-laface
 193         write (ulsort,*) ' decfac : ',decfac(laface)
 194         write (ulsort,*) ' etat   : ',hetqua(-laface)
 195         write (ulsort,*) ' niveau : ',nivqua(-laface)
 196         if ( nbheto.gt.0 ) then
 197         write (ulsort,*) ' volqua(*,laface) : ',
 198      >         volqua(1,-laface),volqua(2,-laface)
 199         if ( volqua(1,-laface).gt.0 ) then
 200         write (ulsort,*) ' etat du voisin 1 : ',
 201      >                   hethex(volqua(1,-laface))
 202         endif
 203         if ( volqua(2,-laface).gt.0 ) then
 204         write (ulsort,*) ' etat du voisin 2 : ',
 205      >                   hethex(volqua(2,-laface))
 206         endif
 207         write(ulsort,*) ' perqua : ',perqua(-laface)
 208           endif
 209           endif
 210           endif
 211 #endif
 212 c
 213 c 2.1. ==> on s'interesse aux faces :
 214 c          . du niveau courant
 215 c          . a decouper
 216 c          . qui ne sont pas au bord du domaine
 217 c
 218         if ( decfac(laface).eq.4 ) then
 219 c
 220         afaire = 0
 221 c
 222         if ( laface.gt.0 ) then
 223 c
 224           if ( nivtri(laface).eq.niveau ) then
 225             afaire = 1
 226           endif
 227 c
 228         elseif ( laface.lt.0 ) then
 229 c
 230           iaux = -laface
 231           if ( nivqua(iaux).eq.niveau ) then
 232             afaire = 1
 233           endif
 234 c
 235         endif
 236 c
 237 c 2.2. ==> on regarde le voisin non decoupe de la face mere
 238 c          attention : on ne traite que les volumes traditionnels
 239 c                      tetra ou hexa, d'ou le codret=12
 240 c
 241 #ifdef _DEBUG_HOMARD_
 242           if ( glop.eq.1 ) then
 243         write (ulsort,*) ' afaire : ',afaire
 244           endif
 245 #endif
 246         if ( afaire.gt.0 ) then
 247 c
 248           if ( laface.gt.0 ) then
 249 c
 250             merefa = pertri(laface)
 251             if ( merefa.gt.0 ) then
 252             if ( voltri(1,merefa).lt.0 .or. voltri(2,merefa).lt.0 ) then
 253                codret = 12
 254                goto 33
 255             endif
 256 c
 257             if ( voltri(1,merefa).gt.0 .and.
 258      >           voltri(2,merefa).gt.0 ) then
 259 c
 260               do 2211 , iaux = 1 , 2
 261                 letetr = voltri(iaux,merefa)
 262                 if ( mod(hettet(letetr),100).eq.0 ) then
 263                   do 2212 , jaux = 1 , 4
 264                     iface = tritet(letetr,jaux)
 265                     if ( mod(hettri(iface),10).eq.0 .and.
 266      >                   decfac(iface).ne.4  ) then
 267                       decfac(iface) = 4
 268                       do 2213 , jarelo = 1 , 3
 269                         jarete = aretri(iface,jarelo)
 270                         if ( mod(hetare(jarete),10).eq.0 .and.
 271      >                       decare(jarete).ne.2 ) then
 272                           decare(jarete) = 2
 273                         endif
 274  2213                 continue
 275                     endif
 276  2212             continue
 277                 endif
 278  2211         continue
 279 c
 280               endif
 281 c
 282             endif
 283 c
 284           else
 285 c
 286             merefa = perqua(-laface)
 287             if ( merefa.gt.0 ) then
 288 #ifdef _DEBUG_HOMARD_
 289           if ( glop.eq.1 ) then
 290         write (ulsort,*) ' perqua : ',merefa
 291           endif
 292 #endif
 293             if ( volqua(1,merefa).gt.0 .and.
 294      >           volqua(2,merefa).gt.0 ) then
 295 c
 296               do 2214 , iaux = 1 , 2
 297                 lehexa = volqua(iaux,merefa)
 298 #ifdef _DEBUG_HOMARD_
 299           if ( glop.eq.1 ) then
 300         write (ulsort,*) '..... lehexa : ',lehexa
 301         write (ulsort,*) '..... etat   : ',hethex(lehexa)
 302           endif
 303 #endif
 304                 if ( mod(hethex(lehexa),1000).eq.0 ) then
 305                   do 2215 , jaux = 1 , 6
 306                     iface = quahex(lehexa,jaux)
 307                     if ( mod(hetqua(iface),100).eq.0 .and.
 308      >                   decfac(-iface).ne.4 ) then
 309                       decfac(-iface) = 4
 310                       do 2216 , jarelo = 1 , 4
 311                         jarete = arequa(iface,jarelo)
 312                         if ( mod(hetare(jarete),10).eq.0 .and.
 313      >                       decare(jarete).ne.2 ) then
 314                           decare(jarete) = 2
 315                         endif
 316  2216                 continue
 317                     endif
 318  2215             continue
 319                 endif
 320  2214         continue
 321 c
 322             endif
 323 c
 324             endif
 325 c
 326           endif
 327 c
 328         endif
 329 c
 330         endif
 331 c
 332     2 continue
 333 c
 334 #ifdef _DEBUG_HOMARD_
 335         write (ulsort,*) 'sortie de ',nompro
 336         do 1106 , iaux = 1 , nbquto
 337           write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux)
 338 cgn          write (ulsort,90001) 'quadrangle', iaux,
 339 cgn     >    arequa(iaux,1), arequa(iaux,2),
 340 cgn     >    arequa(iaux,3), arequa(iaux,4)
 341  1106   continue
 342       if ( nbquto.gt.0 ) then
 343         iaux = min(nbquto,5)
 344         write (ulsort,90001) 'quadrangle', iaux,
 345      >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 346      >  decare(arequa(iaux,3)), decare(arequa(iaux,4))
 347         iaux = min(nbquto,8)
 348         write (ulsort,90001) 'quadrangle', iaux,
 349      >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 350      >  decare(arequa(iaux,3)), decare(arequa(iaux,4))
 351       endif
 352 #endif
 353 c
 354 c====
 355 c 3. la fin
 356 c====
 357 c
 358    33 continue
 359 c
 360       if ( codret.ne.0 ) then
 361 c
 362 #include "envex2.h"
 363 c
 364       write (ulsort,texte(langue,1)) 'Sortie', nompro
 365       write (ulsort,texte(langue,2)) codret
 366 c
 367       endif
 368 c
 369 #ifdef _DEBUG_HOMARD_
 370       write (ulsort,texte(langue,1)) 'Sortie', nompro
 371       call dmflsh (iaux)
 372 #endif
 373 c
 374       end