src/tool/Decision/derco1.F

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