src/tool/Decision/dedin2.F

   1       subroutine dedin2 ( decare, decfac,
   2      >                    posifa, facare,
   3      >                    arehom,
   4      >                    hettri, aretri, filtri, nivtri,
   5      >                    hetqua, arequa, filqua, nivqua,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c traitement des DEcisions - Deraffinement : Initialisation - option 2
  28 c                --          -               -                       -
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . decare . e/s . nbarto . decisions des aretes                       .
  34 c . decfac . e/s . -nbquto. decision sur les faces (quad. + tri.)      .
  35 c .        .     . :nbtrto.                                            .
  36 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  37 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  38 c . arehom . e   . nbarto . ensemble des aretes homologues             .
  39 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  40 c . aretri . e   . nbtrto . numeros des 3 aretes des triangles         .
  41 c . filtri . e   . nbtrto . premier fils des triangles                 .
  42 c . nivtri . e   . nbtrto . niveau des triangles                       .
  43 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  44 c . arequa . e   . nbquto . numeros des 4 aretes des quadrangles       .
  45 c . filqua . e   . nbquto . fils des quadrangles                       .
  46 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  47 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  48 c . langue . e   .    1   . langue des messages                        .
  49 c .        .     .        . 1 : francais, 2 : anglais                  .
  50 c . codret .  s  .    1   . code de retour des modules                 .
  51 c .        .     .        . 0 : pas de probleme                        .
  52 c .        .     .        . 1 : probleme                               .
  53 c ______________________________________________________________________
  54 c
  55 c====
  56 c 0. declarations et dimensionnement
  57 c====
  58 c
  59 c 0.1. ==> generalites
  60 c
  61       implicit none
  62       save
  63 c
  64       character*6 nompro
  65       parameter ( nompro = 'DEDIN2' )
  66 c
  67 #include "nblang.h"
  68 c
  69 c 0.2. ==> communs
  70 c
  71 #include "envex1.h"
  72 c
  73 #include "envada.h"
  74 #include "nombar.h"
  75 #include "nombtr.h"
  76 #include "nombqu.h"
  77 #include "impr02.h"
  78 c
  79 c 0.3. ==> arguments
  80 c
  81       integer decare(0:nbarto)
  82       integer decfac(-nbquto:nbtrto)
  83       integer posifa(0:nbarto), facare(nbfaar)
  84       integer arehom(nbarto)
  85       integer hettri(nbtrto), aretri(nbtrto,3)
  86       integer filtri(nbtrto), nivtri(nbtrto)
  87       integer hetqua(nbquto), arequa(nbquto,4)
  88       integer filqua(nbquto), nivqua(nbquto)
  89 c
  90       integer ulsort, langue, codret
  91 c
  92 c 0.4. ==> variables locales
  93 c
  94       integer laface, larete, niveau, numfac, etatfa, nuarvo, nufavo
  95       integer iaux, ideb, ifin, jdeb, jfin, arevoi, facvoi, iarelo
  96       integer nivdeb, nivfin
  97       integer nbare1, liare1(4), nbare2, liare2(4)
  98       integer kaux, option
  99 c
 100       logical afaire
 101 c
 102       integer nbmess
 103       parameter ( nbmess = 30 )
 104       character*80 texte(nblang,nbmess)
 105 c
 106 c 0.5. ==> initialisations
 107 c ______________________________________________________________________
 108 c
 109 c====
 110 c 1. messages
 111 c====
 112 c
 113 #include "impr01.h"
 114 c
 115 #ifdef _DEBUG_HOMARD_
 116       write (ulsort,texte(langue,1)) 'Entree', nompro
 117       call dmflsh (iaux)
 118 #endif
 119 c
 120 #include "impr03.h"
 121 c
 122 #include "derco1.h"
 123 c
 124       codret = 0
 125 c
 126 c====
 127 c 2. on regarde tous les niveaux dans l'ordre croissant
 128 c====
 129 c
 130       nivdeb = max(nivinf-1,0)
 131       nivfin = nivsup - 1
 132       do 100 , niveau = nivdeb , nivfin
 133 c
 134 #ifdef _DEBUG_HOMARD_
 135       write (ulsort,texte(langue,3)) niveau
 136 #endif
 137 c
 138 c       boucle sur toutes les faces marquee "a reactiver"
 139 c       dans le niveau courant
 140 c
 141         do 2 , laface = -nbquto , nbtrto
 142 c
 143           if ( decfac(laface).eq.-1 ) then
 144 c
 145 c       on regarde toutes les faces meres d'actives du niveau courant
 146 c
 147             etatfa = -1
 148             if ( laface.gt.0 ) then
 149               if ( nivtri(laface).eq.niveau ) then
 150                 etatfa = mod( hettri(laface) , 10 )
 151               endif
 152             elseif ( laface.lt.0 ) then
 153               iaux = -laface
 154               if ( nivqua(iaux).eq.niveau ) then
 155                 etatfa = mod( hetqua(iaux) , 100 )
 156               endif
 157             endif
 158 c
 159             if ( etatfa.ge.4 .and. etatfa.le.8 ) then
 160 c
 161 c 2.1. ==> liste des aretes de la face "a reactiver"
 162 c
 163               if ( laface.gt.0 ) then
 164                 nbare1 = 3
 165                 do 211 , iarelo = 1 , nbare1
 166                   liare1(iarelo) = aretri(laface,iarelo)
 167   211           continue
 168               else
 169                 nbare1 = 4
 170                 iaux = -laface
 171                 do 212 , iarelo = 1 , nbare1
 172                   liare1(iarelo) = arequa(iaux,iarelo)
 173   212           continue
 174               endif
 175 c
 176 c 2.2. ==> Pour un triangle, si le premier triangle fils (central) est
 177 c          marque "a couper" (on ne teste ici que le premier fils
 178 c          car les trois autres sont testes ensuite), le triangle pere
 179 c          est a garder, de meme que ses aretes
 180 c
 181               if ( laface.gt.0 ) then
 182 c
 183                 numfac = filtri(laface)
 184 c
 185                 if ( decfac(numfac).gt.0 ) then
 186 c
 187                   decfac(laface) = max(0,decfac(laface))
 188                   do 221 , iarelo = 1 , nbare1
 189                     larete = liare1(iarelo)
 190                     decare(larete) = max(0,decare(larete))
 191                     if ( arehom(larete).ne.0 ) then
 192                       decare(abs(arehom(larete))) =
 193      >                                max(0,decare(abs(arehom(larete))))
 194                     endif
 195   221             continue
 196 c
 197                 endif
 198 c
 199                 ideb = filtri(laface) + 1
 200                 ifin = ideb + 2
 201 c
 202               else
 203 c
 204                 ideb = - filqua(-laface) - 3
 205                 ifin = ideb + 3
 206 c
 207               endif
 208 c
 209 c 2.3. ==> si l'une des faces filles sur le bord de la face est marquee
 210 c          "a couper", on empeche le deraffinement de la mere et
 211 c          des faces voisines de la face-mere
 212 c
 213               do 231 , numfac = ideb , ifin
 214 c
 215                 if ( decfac(numfac).gt.0 ) then
 216 c
 217                   decfac(laface) = 0
 218 c
 219                   do 232 , iarelo = 1 , nbare1
 220 c
 221                     larete = liare1(iarelo)
 222                     decare(larete) = max(0,decare(larete))
 223                     if ( arehom(larete).ne.0 ) then
 224                       decare(abs(arehom(larete))) =
 225      >                              max(0,decare(abs(arehom(larete))))
 226                     endif
 227 c
 228                     jdeb = posifa(larete-1) + 1
 229                     jfin = posifa(larete)
 230 c
 231                     do 233 , nufavo = jdeb , jfin
 232 c
 233                       facvoi = facare(nufavo)
 234                       decfac(facvoi) = 0
 235 c
 236                       if ( facvoi.gt.0 ) then
 237                         nbare2 = 3
 238                         do 234 , nuarvo = 1 , nbare2
 239                           liare2(nuarvo) = aretri(facvoi,nuarvo)
 240   234                   continue
 241                       else
 242                         iaux = -facvoi
 243                         nbare2 = 4
 244                         do 235 , nuarvo = 1 , nbare2
 245                           liare2(nuarvo) = arequa(iaux,nuarvo)
 246   235                   continue
 247                       endif
 248 c
 249                       do 236 , nuarvo = 1 , nbare2
 250                         arevoi = liare2(nuarvo)
 251                         decare(arevoi) = max(0,decare(arevoi))
 252                         if ( arehom(arevoi).ne.0 ) then
 253                           decare(abs(arehom(arevoi))) =
 254      >                              max(0,decare(abs(arehom(arevoi))))
 255                         endif
 256   236                 continue
 257 c
 258   233               continue
 259 c
 260   232             continue
 261 c
 262                 endif
 263 c
 264   231         continue
 265 c
 266             endif
 267 c
 268           endif
 269 c
 270     2   continue
 271 c
 272   100 continue
 273 c
 274 c====
 275 c 3. on bascule "a garder" toutes les aretes des faces meres
 276 c    non actives "a garder". cette etape est indispensable au
 277 c    fonctionnement correct de la regle des deux voisins.
 278 c    Il faut le transmettre aux eventuelles aretes homologues
 279 c====
 280 c
 281 #ifdef _DEBUG_HOMARD_
 282       write (ulsort,90002) 'Etape 3', codret
 283 #endif
 284 c
 285       do 30 , laface = -nbquto , nbtrto
 286 c
 287         if ( decfac(laface).eq.0 ) then
 288 c
 289           afaire = .false.
 290           if ( laface.gt.0 ) then
 291             etatfa = mod( hettri(laface) , 10 )
 292             if ( etatfa.ge.4 .and. etatfa.le.9 ) then
 293               afaire = .true.
 294             endif
 295           elseif ( laface.lt.0 ) then
 296             iaux = -laface
 297             etatfa = mod( hetqua(iaux) , 100 )
 298             if ( etatfa.eq.4 .or. etatfa.eq.99 ) then
 299               afaire = .true.
 300             endif
 301           endif
 302 c
 303           if ( afaire ) then
 304 #ifdef _DEBUG_HOMARD_
 305             if ( laface.gt.0 ) then
 306               option = 2
 307               iaux=nivtri(laface)
 308             else
 309               option = 4
 310               iaux=nivqua(-laface)
 311             endif
 312             write (ulsort,texte(langue,29)) mess14(langue,1,option),
 313      >      abs(laface), iaux,etatfa, decfac(laface)
 314 #endif
 315             if ( laface.gt.0 ) then
 316               nbare1 = 3
 317               do 31 , iarelo = 1 , nbare1
 318                 liare1(iarelo) = aretri(laface,iarelo)
 319    31         continue
 320             else
 321               nbare1 = 4
 322               iaux = -laface
 323               do 32 , iarelo = 1 , nbare1
 324                 liare1(iarelo) = arequa(iaux,iarelo)
 325    32         continue
 326             endif
 327             do 33 , iarelo = 1 , nbare1
 328               kaux = liare1(iarelo)
 329               if ( decare(kaux).eq.-1 ) then
 330                 decare(kaux) = 0
 331 #ifdef _DEBUG_HOMARD_
 332       write (ulsort,texte(langue,30)) 'decare', kaux, decare(kaux),' '
 333 #endif
 334               endif
 335               if ( arehom(kaux).ne.0 ) then
 336                 if ( decare(abs(arehom(kaux))).eq.-1 ) then
 337                   decare(abs(arehom(kaux))) = 0
 338 #ifdef _DEBUG_HOMARD_
 339       write (ulsort,texte(langue,30)) 'decare',
 340      >  abs(arehom(kaux)), decare(abs(arehom(kaux))), '(homologue)'
 341 #endif
 342                 endif
 343               endif
 344    33       continue
 345           endif
 346 c
 347         endif
 348 c
 349    30  continue
 350 c
 351 c====
 352 c 4. la fin
 353 c====
 354 c
 355       if ( codret.ne.0 ) then
 356 c
 357 #include "envex2.h"
 358 c
 359       write (ulsort,texte(langue,1)) 'Sortie', nompro
 360       write (ulsort,texte(langue,2)) codret
 361 c
 362       endif
 363 c
 364 #ifdef _DEBUG_HOMARD_
 365       write (ulsort,texte(langue,1)) 'Sortie', nompro
 366       call dmflsh (iaux)
 367 #endif
 368 c
 369       end