src/tool/Decision/derco4.F

   1       subroutine derco4 ( tyconf,
   2      >                    niveau,
   3      >                    decare, decfac,
   4      >                    hetare, arehom,
   5      >                    posifa, facare,
   6      >                    hettri, aretri, nivtri,
   7      >                    hetqua, arequa, nivqua,
   8      >                    listfa,
   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 - Raffinement : COntamination - option 4
  31 c                --          -             --                     -
  32 c Application de la regle des deux voisins :
  33 c   pilraf = 1 ou 2. libre
  34 c   pilraf = 3. non-conforme avec 1 arete decoupee unique par element
  35 c en presence d'aretes et/ou de faces homologues :
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . tyconf . e   .   1    .  0 : conforme                              .
  41 c .        .     .        .  1 : non-conforme avec au minimum 2 aretes .
  42 c .        .     .        .      non decoupees en 2                    .
  43 c .        .     .        .  2 : non-conforme avec 1 seul noeud        .
  44 c .        .     .        .      pendant par arete                     .
  45 c .        .     .        .  3 : non-conforme fidele a l'indicateur    .
  46 c .        .     .        . -1 : conforme, avec des boites pour les    .
  47 c .        .     .        .      quadrangles, hexaedres et pentaedres  .
  48 c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
  49 c .        .     .        .      decoupee en 2 (boite pour les         .
  50 c .        .     .        .      quadrangles, hexaedres et pentaedres) .
  51 c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
  52 c .        .     .        .      decoupee en 2 (boite pour les         .
  53 c .        .     .        .      quadrangles, hexaedres et pentaedres) .
  54 c . niveau . e   .    1   . niveau en cours d'examen                   .
  55 c . decare . es  . nbarto . decisions des aretes                       .
  56 c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
  57 c .        .     . :nbtrto.                                            .
  58 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  59 c . arehom . e   . nbarto . ensemble des aretes homologues             .
  60 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  61 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  62 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  63 c . aretri . e   . nbtrto . numeros des 3 aretes des triangles         .
  64 c . nivtri . e   . nbtrto . niveau des triangles                       .
  65 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  66 c . arequa . e   . nbquto . numeros des 4 aretes des quadrangles       .
  67 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  68 c . listfa . t   .   *    . liste de faces a considerer                .
  69 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  70 c . langue . e   .    1   . langue des messages                        .
  71 c .        .     .        . 1 : francais, 2 : anglais                  .
  72 c . codret . es  .    1   . code de retour des modules                 .
  73 c .        .     .        . 0 : pas de probleme                        .
  74 c ______________________________________________________________________
  75 c
  76 c====
  77 c 0. declarations et dimensionnement
  78 c====
  79 c
  80 c 0.1. ==> generalites
  81 c
  82       implicit none
  83       save
  84 c
  85       character*6 nompro
  86       parameter ( nompro = 'DERCO4' )
  87 c
  88 #include "nblang.h"
  89 c
  90 c 0.2. ==> communs
  91 c
  92 #include "envex1.h"
  93 #include "nombar.h"
  94 #include "nombtr.h"
  95 #include "nombqu.h"
  96 c
  97 c 0.3. ==> arguments
  98 c
  99       integer tyconf
 100       integer niveau
 101       integer decare(0:nbarto)
 102       integer hetare(nbarto)
 103       integer decfac(-nbquto:nbtrto)
 104       integer posifa(0:nbarto), facare(nbfaar)
 105       integer arehom(nbarto)
 106       integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto)
 107       integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto)
 108       integer listfa(*)
 109 c
 110       integer ulsort, langue, codret
 111 c
 112 c 0.4. ==> variables locales
 113 c
 114       integer facact, laface, nbfali
 115       integer ipos
 116       integer iaux, ideb, ifin, ifacli
 117       integer nbaret, nbar00, anodec(4)
 118       integer kaux
 119       integer iarelo, iarete, iface
 120       integer etatar, etatfa
 121       integer nbare1, liare1(4)
 122 c
 123       integer nbmess
 124       parameter ( nbmess = 30 )
 125       character*80 texte(nblang,nbmess)
 126 c
 127 c 0.5. ==> initialisations
 128 c ______________________________________________________________________
 129 c
 130 c====
 131 c 1. initialisations
 132 c====
 133 c
 134 #include "impr01.h"
 135 c
 136 #ifdef _DEBUG_HOMARD_
 137       write (ulsort,texte(langue,1)) 'Entree', nompro
 138       call dmflsh (iaux)
 139 #endif
 140 c
 141 #include "impr03.h"
 142 c
 143 #include "derco1.h"
 144 c
 145 #ifdef _DEBUG_HOMARD_
 146       write (ulsort,texte(langue,12)) niveau
 147 #endif
 148 c
 149       codret = 0
 150 c
 151 c     initialisation vide de la liste de faces a examiner
 152 c
 153       nbfali = 0
 154 c
 155 c     initialisation du nombre d'aretes autorisees pour un quadrangle
 156 c
 157       if ( tyconf.eq.0 ) then
 158         nbar00 = -2
 159       else
 160         nbar00 = 2
 161       endif
 162 c
 163 c====
 164 c 2. Application de la regle des deux voisins
 165 c====
 166 c
 167       do 2 , laface = -nbquto , nbtrto
 168 c
 169 c       on regarde toutes les faces actives du niveau courant
 170 c
 171         etatfa = -1
 172         if ( laface.gt.0 ) then
 173           if ( nivtri(laface).eq.niveau ) then
 174             etatfa = mod( hettri(laface) , 10 )
 175           endif
 176         elseif ( laface.lt.0 ) then
 177           iaux = -laface
 178           if ( nivqua(iaux).eq.niveau ) then
 179             etatfa = mod( hetqua(iaux) , 100 )
 180           endif
 181         endif
 182 c
 183         if ( etatfa.eq.0 ) then
 184 c
 185           facact = laface
 186 c
 187 c         debut du traitement de la face courante
 188 c         ***************************************
 189 c
 190 c         --------
 191    20     continue
 192 c         --------
 193 c         on ne regarde que les faces "a garder"
 194 c
 195           if ( decfac(facact).eq.0 ) then
 196 c
 197 c 2.1. ==> on compte les aretes actives a garder et les aretes
 198 c          inactives a reactiver
 199 c
 200             if ( facact.gt.0 ) then
 201               nbare1 = 3
 202               do 211 , iarelo = 1 , nbare1
 203                 liare1(iarelo) = aretri(facact,iarelo)
 204   211         continue
 205             else
 206               nbare1 = 4
 207               iaux = -facact
 208               do 212 , iarelo = 1 , nbare1
 209                 liare1(iarelo) = arequa(iaux,iarelo)
 210   212         continue
 211             endif
 212 c
 213             nbaret = 0
 214             do 213 , iarelo = 1 , nbare1
 215               iarete = liare1(iarelo)
 216               if ( decare(iarete).eq.0 ) then
 217                 etatar = mod( hetare(iarete) , 10 )
 218                 if ( etatar.eq.0 ) then
 219                   nbaret = nbaret + 1
 220                   anodec(nbaret) = iarete
 221                 endif
 222               elseif ( decare(iarete).eq.-1 ) then
 223                 nbaret = nbaret + 1
 224                 anodec(nbaret) = iarete
 225               endif
 226   213       continue
 227 c
 228 c 2.2. ==> aucune arete n'est une active a garder
 229 c          ------------------------------------
 230 c          ==> on declare la face "a couper"
 231 c
 232             if ( nbaret.eq.0 ) then
 233 c
 234               decfac(facact) = 4
 235 c
 236 c 2.3. ==> une seule arete est une active a garder
 237 c          ---------------------------------------
 238 c
 239             elseif ( nbaret.eq.1 ) then
 240 c
 241 c 2.3.1. ==>  on declare la face "a couper"
 242 c             . si l'arete est active, on la declare "a couper"
 243 c             . si l'arete est inactive, on la declare "a garder"
 244 c
 245               decfac(facact) = 4
 246               if ( mod(hetare(anodec(1)),10).eq.0 ) then
 247                 decare(anodec(1)) = 2
 248               else
 249                 decare(anodec(1)) = 0
 250               endif
 251 c
 252 c             on regarde toutes les faces qui s'appuient sur cette
 253 c             arete, on memorise celles qui sont actives "a garder"
 254 c
 255               ideb = posifa(anodec(1)-1)+1
 256               ifin = posifa(anodec(1))
 257 c
 258               do 231 , ipos = ideb , ifin
 259                 iface = facare(ipos)
 260                 if ( decfac(iface).eq.0 ) then
 261                   if ( iface.gt.0 ) then
 262                     etatfa = mod( hettri(iface) , 10 )
 263                   else
 264                     etatfa = mod( hetqua(-iface) , 100 )
 265                   endif
 266                   if ( etatfa.eq.0 ) then
 267                     do 2311 , ifacli = 1 , nbfali
 268                       if ( listfa(ifacli).eq.iface ) then
 269                         goto 2312
 270                       endif
 271  2311               continue
 272                     nbfali = nbfali + 1
 273                     listfa(nbfali) = iface
 274  2312               continue
 275                   endif
 276                 endif
 277   231         continue
 278 c
 279 c 2.3.2. ==> on regarde si l'arete a une homologue
 280 c
 281               if ( arehom(anodec(1)) .ne. 0 ) then
 282 c
 283                 kaux = abs( arehom(anodec(1)) )
 284 c
 285 c          . si l'arete homologue est active, on la declare "a couper"
 286 c          . si l'arete homologue est inactive, on la declare "a garder"
 287 c
 288                 if ( mod(hetare(kaux),10).eq.0 ) then
 289                   decare(kaux) = 2
 290                 else
 291                   decare(kaux) = 0
 292                 endif
 293 c
 294 c               on regarde toutes les faces qui s'appuient sur cette
 295 c               arete, on memorise celles qui sont actives a "garder"
 296 c
 297                 ideb = posifa(kaux-1) + 1
 298                 ifin = posifa(kaux)
 299 c
 300                 do 232, ipos = ideb , ifin
 301                   iface = facare(ipos)
 302                   if ( decfac(iface).eq.0 ) then
 303                     if ( iface.gt.0 ) then
 304                       etatfa = mod( hettri(iface) , 10 )
 305                     else
 306                       etatfa = mod( hetqua(-iface) , 100 )
 307                     endif
 308                     if ( etatfa.eq.0 ) then
 309                       do 2321 , ifacli = 1 , nbfali
 310                         if ( listfa(ifacli).eq.iface ) then
 311                           goto 2322
 312                         endif
 313  2321                 continue
 314                       nbfali = nbfali + 1
 315                       listfa(nbfali) = iface
 316  2322                 continue
 317                     endif
 318                   endif
 319   232           continue
 320 c
 321               endif
 322 c
 323 c 2.4. ==> pour un quadrangle, deux aretes sont
 324 c          ------------------------------------
 325 c          des actives a garder si on veut des boites
 326 c          ------------------------------------------
 327 c
 328             elseif ( facact.lt.0 ) then
 329 c
 330               if ( nbaret.eq.nbar00 ) then
 331 c
 332 c             on declare la face "a couper"
 333 c
 334                 decfac(facact) = 4
 335 c
 336                 do 24 , iaux = 1 , 2
 337 c
 338 c 2.4.1. ==>  . si l'arete est active, on la declare "a couper"
 339 c             . si l'arete est inactive, on la declare "a garder"
 340 c
 341                   if ( mod(hetare(anodec(iaux)),10).eq.0 ) then
 342                     decare(anodec(iaux)) = 2
 343                   else
 344                     decare(anodec(iaux)) = 0
 345                   endif
 346 c
 347 c                 on regarde toutes les faces qui s'appuient sur cette
 348 c                 arete, on memorise celles qui sont actives "a garder"
 349 c
 350                   ideb = posifa(anodec(iaux)-1)+1
 351                   ifin = posifa(anodec(iaux))
 352 c
 353                   do 241 , ipos = ideb , ifin
 354                     iface = facare(ipos)
 355                     if ( decfac(iface).eq.0 ) then
 356                       if ( iface.gt.0 ) then
 357                         etatfa = mod( hettri(iface) , 10 )
 358                       else
 359                         etatfa = mod( hetqua(-iface) , 100 )
 360                       endif
 361                       if ( etatfa.eq.0 ) then
 362                         do 2412 , ifacli = 1 , nbfali
 363                           if ( listfa(ifacli).eq.iface ) then
 364                             goto 2413
 365                           endif
 366  2412                  continue
 367                         nbfali = nbfali + 1
 368                         listfa(nbfali) = iface
 369  2413                  continue
 370                       endif
 371                     endif
 372   241             continue
 373 c
 374 c 2.4.2. ==>  . si l'arete a une homolgue
 375 c
 376                   if ( arehom(anodec(iaux)) .ne. 0 ) then
 377 c
 378                     kaux = abs( arehom(anodec(iaux)) )
 379 c
 380 c          . si l'arete homologue est active, on la declare "a couper"
 381 c          . si l'arete homologue est inactive, on la declare "a garder"
 382 c
 383                     if ( mod(hetare(kaux),10).eq.0 ) then
 384                       decare(kaux) = 2
 385                     else
 386                       decare(kaux) = 0
 387                     endif
 388 c
 389 c               on regarde toutes les faces qui s'appuient sur cette
 390 c               arete, on memorise celles qui sont actives a "garder"
 391 c
 392                     ideb = posifa(kaux-1) + 1
 393                     ifin = posifa(kaux)
 394 c
 395                     do 242, ipos = ideb , ifin
 396                       iface = facare(ipos)
 397                       if ( decfac(iface).eq.0 ) then
 398                         if ( iface.gt.0 ) then
 399                           etatfa = mod( hettri(iface) , 10 )
 400                         else
 401                           etatfa = mod( hetqua(-iface) , 100 )
 402                         endif
 403                         if ( etatfa.eq.0 ) then
 404                           do 2421 , ifacli = 1 , nbfali
 405                             if ( listfa(ifacli).eq.iface ) then
 406                               goto 2422
 407                             endif
 408  2421                     continue
 409                           nbfali = nbfali + 1
 410                           listfa(nbfali) = iface
 411  2422                     continue
 412                         endif
 413                       endif
 414   242               continue
 415 c
 416                   endif
 417 c
 418    24           continue
 419 c
 420               endif
 421 c
 422             endif
 423 c
 424           endif
 425 c
 426 c 2.5. ==> on passe a la face suivante de la liste
 427 c          ---------------------------------------
 428 c
 429           if ( nbfali .gt. 0 ) then
 430 c
 431             facact = listfa(nbfali)
 432             nbfali = nbfali - 1
 433             goto 20
 434 c
 435           endif
 436 c
 437         endif
 438 c
 439     2 continue
 440 c
 441 #ifdef _DEBUG_HOMARD_
 442 c====
 443 c 3. verification
 444 c====
 445 c
 446       if ( codret.eq.0 ) then
 447 c
 448       call dehova ( arehom, decare,
 449      >              nompro, 1,
 450      >              ulsort, langue, codret )
 451 c
 452       endif
 453 #endif
 454 c
 455 c====
 456 c 4. la fin
 457 c====
 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