src/tool/Decision/derco6.F

   1       subroutine derco6 ( niveau,
   2      >                    decare, decfac,
   3      >                    merare, arehom,
   4      >                    posifa, facare,
   5      >                    hettri, aretri, pertri, nivtri,
   6      >                    voltri,
   7      >                    hetqua, arequa, perqua, nivqua,
   8      >                    tritet,
   9      >                    listfa,
  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 6
  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 en presence d'aretes et/ou de faces homologues
  36 c Remarque : cela ne peut concerner que des niveaux au moins egal a 2
  37 c ______________________________________________________________________
  38 c .        .     .        .                                            .
  39 c .  nom   . e/s . taille .           description                      .
  40 c .____________________________________________________________________.
  41 c . niveau . e   .    1   . niveau en cours d'examen                   .
  42 c . decare . es  . nbarto . decisions des aretes                       .
  43 c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
  44 c .        .     . :nbtrto.                                            .
  45 c . merare . e   . nbarto . mere des aretes                            .
  46 c . arehom . e   . nbarto . ensemble des aretes homologues             .
  47 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  48 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  49 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  50 c . aretri . e   . nbtrto . numeros des 3 aretes des triangles         .
  51 c . pertri . e   . nbtrto . pere des triangles                         .
  52 c . nivtri . e   . nbtrto . niveau des triangles                       .
  53 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  54 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  55 c .        .     .        .   0 : pas de voisin                        .
  56 c .        .     .        . j>0 : tetraedre j                          .
  57 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  58 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  59 c . arequa . e   . nbquto . numeros des 4 aretes des quadrangles       .
  60 c . perqua . e   . nbquto . pere des quadrangles                       .
  61 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  62 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  63 c . listfa . t   .   *    . liste de faces a considerer                .
  64 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  65 c . langue . e   .    1   . langue des messages                        .
  66 c .        .     .        . 1 : francais, 2 : anglais                  .
  67 c . codret . es  .    1   . code de retour des modules                 .
  68 c .        .     .        . 0 : pas de probleme                        .
  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 = 'DERCO6' )
  82 c
  83 #include "nblang.h"
  84 c
  85 c 0.2. ==> communs
  86 c
  87 #include "envex1.h"
  88 #include "nombar.h"
  89 #include "nombtr.h"
  90 #include "nombqu.h"
  91 #include "nombte.h"
  92 c
  93 c 0.3. ==> arguments
  94 c
  95       integer niveau
  96       integer decare(0:nbarto)
  97       integer decfac(-nbquto:nbtrto)
  98       integer merare(nbarto), arehom(nbarto)
  99       integer posifa(0:nbarto), facare(nbfaar)
 100       integer hettri(nbtrto), aretri(nbtrto,3)
 101       integer pertri(nbtrto), nivtri(nbtrto)
 102       integer voltri(2,nbtrto)
 103       integer hetqua(nbquto), arequa(nbquto,4)
 104       integer perqua(nbquto), nivqua(nbquto)
 105       integer tritet(nbtecf,4)
 106       integer listfa(*)
 107 c
 108       integer ulsort, langue, codret
 109 c
 110 c 0.4. ==> variables locales
 111 c
 112       integer laface, tetrae, nbtetr
 113       integer ipos, ipos1
 114       integer ideb, ifin, ifacli, nbfali
 115       integer iaux, jaux, kaux, jfin
 116       integer iarelo, jarelo, ifalo, iarete, jarete, iface, itetra
 117       integer etatfa, merear, merefa, grdmfa
 118       integer nbare1, nbare2, liare1(4), liare2(4), liare3(2)
 119 c
 120       integer nbmess
 121       parameter ( nbmess = 30 )
 122       character*80 texte(nblang,nbmess)
 123 c
 124 c 0.5. ==> initialisations
 125 c ______________________________________________________________________
 126 c
 127 c====
 128 c 1. initialisations
 129 c====
 130 c
 131 #include "impr01.h"
 132 c
 133 #ifdef _DEBUG_HOMARD_
 134       write (ulsort,texte(langue,1)) 'Entree', nompro
 135       call dmflsh (iaux)
 136 #endif
 137 c
 138 #include "derco1.h"
 139 c
 140 #ifdef _DEBUG_HOMARD_
 141       write (ulsort,texte(langue,12)) niveau
 142 #endif
 143 c
 144       codret = 0
 145 c
 146 c  nombre maximum de tetraedres par triangle
 147 c
 148       if ( nbteto.eq.0 ) then
 149         nbtetr = 0
 150       else
 151         nbtetr = 2
 152       endif
 153 c
 154 c     initialisation vide de la liste de faces a examiner
 155 c
 156       nbfali = 0
 157 c
 158 c====
 159 c 2. Complements sur la regle des ecarts de niveau
 160 c====
 161 c
 162       do 2 , laface = -nbquto , nbtrto
 163 cgn        print *,'entree de ',nompro,', ',laface,' :',decfac(laface)
 164 c
 165 c 2.1. ==> on s'interesse aux faces :
 166 c          . du niveau courant
 167 c          . actives
 168 c          . qui ont une mere qui ne reapparait pas
 169 c          . qui ont une grand-mere
 170 c
 171         grdmfa = 0
 172 c
 173         if ( laface.gt.0 ) then
 174 c
 175           if ( nivtri(laface).eq.niveau ) then
 176             etatfa = mod( hettri(laface) , 10 )
 177             if ( etatfa.eq.0 ) then
 178               merefa = pertri(laface)
 179               if ( merefa.gt.0 ) then
 180                 if ( decfac(merefa).eq.0 ) then
 181                   grdmfa = pertri(merefa)
 182                 endif
 183               endif
 184             endif
 185           endif
 186 c
 187         elseif ( laface.lt.0 ) then
 188 c
 189           iaux = -laface
 190           if ( nivqua(iaux).eq.niveau ) then
 191             etatfa = mod( hetqua(iaux) , 100 )
 192             if ( etatfa.eq.0 ) then
 193               merefa = perqua(iaux)
 194               if ( merefa.gt.0 ) then
 195                 if ( decfac(-merefa).eq.0 ) then
 196                   grdmfa = perqua(merefa)
 197                 endif
 198               endif
 199             endif
 200           endif
 201 c
 202         endif
 203 c
 204 c 2.2. ==> on regarde les aretes de la face mere
 205 c
 206         if ( grdmfa.gt.0 ) then
 207 c
 208 c 2.2.1. ==> liste de ces aretes
 209 c
 210           if ( laface.gt.0 ) then
 211 c
 212             nbare2 = 3
 213             do 2211 , iarelo = 1 , nbare2
 214               liare2(iarelo) = aretri(merefa,iarelo)
 215  2211       continue
 216 c
 217           else
 218 c
 219             nbare2 = 4
 220             do 2212 , iarelo = 1 , nbare2
 221               liare2(iarelo) = arequa(merefa,iarelo)
 222  2212       continue
 223 c
 224           endif
 225 c
 226           nbare1 = 0
 227           do 2213 , iaux = 1 , nbare2
 228             if ( decare(liare2(iaux)).eq.0 ) then
 229               nbare1 = nbare1 + 1
 230               liare1(nbare1) = liare2(iaux)
 231             endif
 232  2213     continue
 233 c
 234 c on parcourt les aretes retenues
 235 c
 236           do 220 , iarelo = 1 , nbare1
 237 c
 238             iarete = liare1(iarelo)
 239 c
 240             merear = merare(iarete)
 241 c
 242             if ( merear.ne.0 ) then
 243 c
 244 c 2.2.2. ==> l'arete iarete est sur le bord de la face grdmfa
 245 c            ------------------------------------------------
 246 c                on explore les faces qui s'enroulent autour de
 247 c                l'arete merear et celles qui s'enroulent autour
 248 c                de son eventuelle homologue
 249 c
 250 c               ==> pour toutes les faces qui s'appuient sur merear,
 251 c                   mere de cette arete iarete, ou son homologue :
 252 c                 . si elles sont a reactiver, on les garde
 253 c
 254               liare3(1) = merear
 255               if ( arehom(merear).eq.0 ) then
 256                 jfin = 1
 257               else
 258                 liare3(2) = abs(arehom(merear))
 259                 jfin = 2
 260               endif
 261 c
 262               do 2220 , jaux = 1 , jfin
 263 c
 264                 ideb = posifa(liare3(jaux)-1)+1
 265                 ifin = posifa(liare3(jaux))
 266 c
 267                 do 2221 , ipos = ideb , ifin
 268 c
 269                   iface = facare(ipos)
 270 c
 271                   if ( decfac(iface).eq.-1 ) then
 272 c
 273                     decfac(iface) = 0
 274 #ifdef _DEBUG_HOMARD_
 275       write (ulsort,texte(langue,30))'decfac', iface,decfac(iface),' '
 276 #endif
 277                     if ( iface.gt.0 ) then
 278                       nbare2 = 3
 279                       do 22211 , jarelo = 1 , nbare2
 280                         liare2(jarelo) = aretri(iface,jarelo)
 281 22211                 continue
 282                     else
 283                       nbare2 = 4
 284                       iaux = -iface
 285                       do 22212 , jarelo = 1 , nbare2
 286                         liare2(jarelo) = arequa(iaux,jarelo)
 287 22212                 continue
 288                     endif
 289                     do 22213 , jarelo = 1 , nbare2
 290                       jarete = liare2(jarelo)
 291                       decare(jarete) = 0
 292 #ifdef _DEBUG_HOMARD_
 293       write (ulsort,texte(langue,30))' decare',jarete,decare(jarete),' '
 294 #endif
 295 c
 296 c                   on regarde si l'arete a une homologue
 297 c
 298                       if ( arehom(jarete) .ne. 0 ) then
 299 c
 300                         kaux = abs( arehom(jarete) )
 301                         decare(kaux) = 0
 302 #ifdef _DEBUG_HOMARD_
 303       write (ulsort,texte(langue,30))' decare',kaux,decare(kaux),' '
 304 #endif
 305 c
 306 c                    on regarde toutes les faces qui s'appuient sur
 307 c                    cette arete, on memorise celles qui sont
 308 c                    actives a "garder"
 309 c
 310                         ideb = posifa(kaux-1)+1
 311                         ifin = posifa(kaux)
 312 c
 313                         do 22214, ipos1 = ideb, ifin
 314                           iface = facare(ipos1)
 315                           if ( decfac(iface) .eq. 0 ) then
 316                             if ( iface.gt.0 ) then
 317                               etatfa = mod( hettri(iface) , 10 )
 318                             else
 319                               etatfa = mod( hetqua(-iface) , 100 )
 320                             endif
 321                             if ( etatfa .eq. 0 ) then
 322                               do 22215, ifacli = 1, nbfali
 323                                 if ( listfa(ifacli).eq.iface ) then
 324                                   goto 22216
 325                                 endif
 326 22215                         continue
 327                               nbfali = nbfali + 1
 328                               listfa(nbfali) = iface
 329 22216                         continue
 330                             endif
 331                           endif
 332 22214                   continue
 333                       endif
 334 22213               continue
 335 c
 336                   endif
 337 c
 338  2221           continue
 339 c
 340  2220         continue
 341 c
 342             else
 343 c
 344 c 2.2.3. ==> l'arete iarete est interieure a la face grdmfa
 345 c            ----------------------------------------------
 346 c               ==> pour toutes les faces des tetraedres qui
 347 c                   s'appuient sur le triangle pere grdmfa :
 348 c                 . si elles sont a reactiver, on les garde
 349 c
 350               if ( laface.gt.0 ) then
 351 c
 352                 do 2231 , itetra = 1 , nbtetr
 353 c            attention : on ne traite que les volumes traditionnels
 354 c                        tetra ou hexa, d'ou le codret=12
 355 c
 356             if ( voltri(itetra,grdmfa).lt.0 ) then
 357                codret = 12
 358                goto 33
 359             endif
 360                   tetrae = voltri(itetra,grdmfa)
 361                   if ( tetrae.ne.0 ) then
 362 c
 363                     do 2232 , ifalo = 1 , 4
 364 c
 365                       iface = tritet(tetrae,ifalo)
 366 c
 367                       if ( decfac(iface) .eq. -1 ) then
 368 c
 369                         decfac(iface) = 0
 370 #ifdef _DEBUG_HOMARD_
 371       write (ulsort,texte(langue,30))'decfac', iface,decfac(iface),' '
 372 #endif
 373 c
 374                         do 2233 , jarelo = 1 , 3
 375                           jarete = aretri(iface,jarelo)
 376                           decare(jarete) = 0
 377 #ifdef _DEBUG_HOMARD_
 378       write (ulsort,texte(langue,30))' decare',jarete,decare(jarete),' '
 379 #endif
 380 c
 381 c                         on regarde si l'arete a une homologue
 382 c                                                  ---------
 383                           if ( arehom(jarete).ne.0 ) then
 384 c
 385                             kaux = abs( arehom(jarete) )
 386                             decare(kaux) = 0
 387 #ifdef _DEBUG_HOMARD_
 388       write (ulsort,texte(langue,30))' decare',kaux,decare(kaux),' '
 389 #endif
 390 c
 391 c                       on regarde toutes les faces qui s'appuient sur
 392 c                       cette arete, on memorise celles qui sont
 393 c                       actives a "garder"
 394 c
 395                             ideb = posifa(kaux-1)+1
 396                             ifin = posifa(kaux)
 397 c
 398                             do 2234 , ipos = ideb , ifin
 399                               iface = facare(ipos)
 400                               if ( decfac(iface) .eq. 0 ) then
 401                                 etatfa = mod(hettri(iface),10)
 402                                 if ( etatfa .eq. 0 ) then
 403                                   do 2235 , ifacli = 1 , nbfali
 404                                     if ( listfa(ifacli).eq.iface ) then
 405                                      goto 2236
 406                                     endif
 407  2235                             continue
 408                                   nbfali = nbfali + 1
 409                                   listfa(nbfali) = iface
 410  2236                             continue
 411                                 endif
 412                               endif
 413  2234                       continue
 414 c
 415                           endif
 416 c
 417  2233                   continue
 418 c
 419                       endif
 420 c
 421  2232               continue
 422 c
 423                   endif
 424 c
 425  2231           continue
 426 c
 427               endif
 428 c
 429             endif
 430 c
 431   220     continue
 432 c
 433         endif
 434 c
 435     2 continue
 436 c
 437 #ifdef _DEBUG_HOMARD_
 438 c====
 439 c 3. verification
 440 c====
 441 c
 442       if ( codret.eq.0 ) then
 443 c
 444       call dehova ( arehom, decare,
 445      >              nompro, 1,
 446      >              ulsort, langue, codret )
 447 c
 448       endif
 449 #endif
 450 c
 451 cgn        print *,'sortie de ',nompro,', ',laface,' :',decfac(laface)
 452 c
 453 c====
 454 c 4. la fin
 455 c====
 456 c
 457    33 continue
 458 c
 459       if ( codret.ne.0 ) then
 460 c
 461 #include "envex2.h"
 462 c
 463       write (ulsort,texte(langue,1)) 'Sortie', nompro
 464       write (ulsort,texte(langue,2)) codret
 465 c
 466       endif
 467 c
 468 #ifdef _DEBUG_HOMARD_
 469       write (ulsort,texte(langue,1)) 'Sortie', nompro
 470       call dmflsh (iaux)
 471 #endif
 472 c
 473       end