src/tool/Decision/dedin1.F

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