src/tool/Decision/decr03.F

   1       subroutine decr03 ( decfac, decare,
   2      >                    hetare, posifa, facare,
   3      >                    hettri, aretri,
   4      >                    hetqua, arequa,
   5      >                    listef,
   6      >                    afaire,
   7      >                    ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c traitement des DEcisions - Contraintes de Raffinement - 03
  29 c                --          -              -             --
  30 c    Bande de raffinement interdite
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
  36 c .        .     . :nbtrto.                                            .
  37 c . decare . es  . nbarto . decisions des aretes                       .
  38 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  39 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  40 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  41 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  42 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  43 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  44 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  45 c . listef . aux . nbquto/. auxiliaire sur les faces (quad. + tri.)    .
  46 c .        .     . nbtrto .                                            .
  47 c . afaire . es  .    1   . que faire a la sortie                      .
  48 c .        .     .        . 0 : aucune action                          .
  49 c .        .     .        . 1 : refaire une iteration de l'algorithme  .
  50 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  51 c . langue . e   .    1   . langue des messages                        .
  52 c .        .     .        . 1 : francais, 2 : anglais                  .
  53 c . codret . es  .    1   . code de retour des modules                 .
  54 c .        .     .        . 0 : pas de probleme                        .
  55 c .        .     .        . sinon : probleme                           .
  56 c ______________________________________________________________________
  57 c
  58 c====
  59 c 0. declarations et dimensionnement
  60 c====
  61 c
  62 c 0.1. ==> generalites
  63 c
  64       implicit none
  65       save
  66 c
  67       character*6 nompro
  68       parameter ( nompro = 'DECR03' )
  69 c
  70 #include "nblang.h"
  71 c
  72 c 0.2. ==> communs
  73 c
  74 #include "envex1.h"
  75 c
  76 #include "nombar.h"
  77 #include "nombtr.h"
  78 #include "nombqu.h"
  79 #include "impr02.h"
  80 c
  81 c 0.3. ==> arguments
  82 c
  83       integer decfac(-nbquto:nbtrto), decare(0:nbarto)
  84       integer hetare(nbarto)
  85       integer posifa(0:nbarto), facare(nbfaar)
  86       integer hettri(nbtrto), aretri(nbtrto,3)
  87       integer hetqua(nbquto), arequa(nbquto,4)
  88       integer listef(*)
  89       integer afaire
  90 c
  91       integer ulsort, langue, codret
  92 c
  93 c 0.4. ==> variables locales
  94 c
  95       integer ipos
  96       integer iaux, ideb, ifin
  97       integer laface, faced, etatfa
  98       integer larelo, larete, iface
  99       integer option, nbento, nbaret
 100       integer nbface, nbarpb
 101       integer infare(4), listar(4)
 102 c
 103       integer nbmess
 104       parameter ( nbmess = 30 )
 105       character*80 texte(nblang,nbmess)
 106 c
 107 c 0.5. ==> initialisations
 108 c ______________________________________________________________________
 109 c
 110 c====
 111 c 1. messages
 112 c====
 113 c
 114 #include "impr01.h"
 115 c
 116 #ifdef _DEBUG_HOMARD_
 117       write (ulsort,texte(langue,1)) 'Entree', nompro
 118       call dmflsh (iaux)
 119 #endif
 120 c
 121       texte(1,4) = '(5x,''Bande interdite.'')'
 122       texte(1,5) = '(7x,''Nombre de faces a reconsiderer :'',i6,/)'
 123       texte(1,6) = '(''. Probleme avec le '',a,i6)'
 124       texte(1,7) =
 125      > '(a,''numero '',i6,'' : decision ='',i2,'', etat ='',i5)'
 126 c
 127       texte(2,4) = '(5x,''No band.'')'
 128       texte(2,5) = '(7x,''Number of faces to deal with :'',i6,/)'
 129       texte(2,6) = '(''. Problem with '',a,''#'',i6)'
 130       texte(2,7) =
 131      > '(a,''#'',i6,'' : decision ='',i2,'', status ='',i5)'
 132 c
 133 #include "impr03.h"
 134 c
 135 #include "derco1.h"
 136 c
 137       codret = 0
 138 c
 139       write (ulsort,texte(langue,4))
 140 c
 141 c====
 142 c 2. on interdit les situations ou on aurait apparition d'une bande :
 143 c    En triangle :
 144 c    . un triangle coupe dont aucun voisin ne serait decoupe
 145 c                 .                         .-------------.
 146 c                . .                        .             .
 147 c               .   .                       .             .
 148 c              .     .                      .             .
 149 c             .       .                     .             .
 150 c            .         .                    .             .
 151 c           .           .                   .             .
 152 c          .-------------.                  .-------------.
 153 c         . .     ..    . .                . .     ..    . .
 154 c        .   .   .  .  .   .              .   .   .  .  .   .
 155 c       .     . .    ..     .            .     . .    ..     .
 156 c      .       .-----.       .          .       .-----.       .
 157 c     .         .   .         .        .         .   .         .
 158 c    .           . .           .      .           . .           .
 159 c    -------------.-------------      -------------.-------------
 160 c
 161 c    . un triangle coupe dont un seul voisin est decoupe
 162 c                        .
 163 c                       . .
 164 c                      .   .
 165 c                     .     .
 166 c                    .       .
 167 c                   .         .
 168 c                  .           .
 169 c                 .-------------.
 170 c                . .     ..    . .
 171 c               .   .   .  .  .   .
 172 c              .     . .    ..     .
 173 c             .       .-----. ------.
 174 c            .         .   .  .   .  .
 175 c           .           . .    . .    .
 176 c           -------------.------.------
 177 c
 178 c    En quadrangle :
 179 c    . un quadrangle coupe dont aucun voisin ne serait decoupe
 180 c
 181 c            -------------------------------------------
 182 c            .             .             .             .
 183 c            .             .             .             .
 184 c            .             .             .             .
 185 c            .             .             .             .
 186 c            .             .             .             .
 187 c            -------------------------------------------
 188 c            .             .      .      .             .
 189 c            .             .      .      .             .
 190 c            .             .-------------.             .
 191 c            .             .      .      .             .
 192 c            .             .      .      .             .
 193 c            -------------------------------------------
 194 c            .             .             .             .
 195 c            .             .             .             .
 196 c            .             .             .             .
 197 c            .             .             .             .
 198 c            .             .             .             .
 199 c            -------------------------------------------
 200 c
 201 c    . un quadrangle coupe dont aucun voisin ne serait decoupe
 202 c      dans une direction
 203 c
 204 c            -------------------------------------------
 205 c            .             .             .             .
 206 c            .             .             .             .
 207 c            .             .             .             .
 208 c            .             .             .             .
 209 c            .             .             .             .
 210 c            -------------------------------------------
 211 c            .             .      .      .      .      .
 212 c            .             .      .      .      .      .
 213 c            .             .-------------.-------------.
 214 c            .             .      .      .      .      .
 215 c            .             .      .      .      .      .
 216 c            -------------------------------------------
 217 c            .             .             .             .
 218 c            .             .             .             .
 219 c            .             .             .             .
 220 c            .             .             .             .
 221 c            .             .             .             .
 222 c            -------------------------------------------
 223 c
 224 c            -------------------------------------------
 225 c            .             .             .             .
 226 c            .             .             .             .
 227 c            .             .             .             .
 228 c            .             .             .             .
 229 c            .             .             .             .
 230 c            -------------------------------------------
 231 c            .      .      .      .      .      .      .
 232 c            .      .      .      .      .      .      .
 233 c            .-------------.-------------.-------------.
 234 c            .      .      .      .      .      .      .
 235 c            .      .      .      .      .      .      .
 236 c            -------------------------------------------
 237 c            .             .             .             .
 238 c            .             .             .             .
 239 c            .             .             .             .
 240 c            .             .             .             .
 241 c            .             .             .             .
 242 c            -------------------------------------------
 243 c
 244 c     Dans ces cas-la, il faut imposer le decoupage sur 1 ou 2 voisins
 245 c
 246 c     On parcourt les faces coupees ou a couper. On compte combien elles
 247 c     possedent de faces voisines coupees ou a couper
 248 c====
 249 c
 250       nbface = 0
 251 c
 252       do 2 , option = 2, 4, 2
 253 c
 254 #ifdef _DEBUG_HOMARD_
 255         write (ulsort,*) mess14(langue,2,option)
 256 #endif
 257 c
 258         if ( option.eq.2 ) then
 259           nbento = nbtrto
 260           nbaret = 3
 261         else
 262           nbento = nbquto
 263           nbaret = 4
 264        endif
 265 c
 266         do 20 , laface = 1 , nbento
 267 c
 268           if ( option.eq.2 ) then
 269             etatfa = mod( hettri(laface) , 10 )
 270             faced = laface
 271           else
 272             etatfa = mod( hetqua(laface) , 100 )
 273             faced = -laface
 274           endif
 275 c
 276           if ( ( etatfa.eq.0 .and. decfac(faced).eq.4 ) .or.
 277      >           etatfa.eq.4 .and. decfac(faced).ne.-1 ) then
 278 #ifdef _DEBUG_HOMARD_
 279           write (ulsort,*)' '
 280           write (ulsort,texte(langue,7))mess14(langue,1,option),
 281      > laface,decfac(faced),etatfa
 282 #endif
 283 c
 284 c 2.1. ==> on parcourt chacune des aretes ; on remplit le tableau infare
 285 c          infare(ar) =  0 : une au moins des faces s'appuyant sur
 286 c                            l'arete restera non decoupee
 287 c          infare(ar) =  2 : toutes les faces s'appuyant sur l'arete
 288 c                            sont coupees ou a couper
 289 c          infare(ar) = -1 : l'arete est au bord
 290 c
 291             do 21 , larelo = 1 , nbaret
 292 c
 293               if ( option.eq.2 ) then
 294                 larete = aretri(laface,larelo)
 295               else
 296                 larete = arequa(laface,larelo)
 297               endif
 298 #ifdef _DEBUG_HOMARD_
 299           write (ulsort,texte(langue,7))'.. '//mess14(langue,1,1),
 300      > larete,decare(larete),hetare(larete)
 301 #endif
 302               ideb = posifa(larete-1)+1
 303               ifin = posifa(larete)
 304 c
 305               if ( ideb.eq.ifin ) then
 306                 infare(larelo) = -1
 307               else
 308 c
 309                 infare(larelo) = 2
 310                 do 211 , ipos = ideb , ifin
 311                   iface = facare(ipos)
 312                   if ( iface.ne.faced) then
 313                     if ( iface.gt.0 ) then
 314                       etatfa = mod( hettri(iface) , 10 )
 315                     else
 316                       etatfa = mod( hetqua(-iface) , 100 )
 317                     endif
 318 #ifdef _DEBUG_HOMARD_
 319        write (ulsort,texte(langue,7))'.... '//mess14(langue,1,option),
 320      > abs(iface),decfac(iface),etatfa
 321 #endif
 322                     if ( etatfa.ne.0 .and. decfac(iface).ne.-1 ) then
 323                       goto 21
 324                     else if ( decfac(iface).eq.4 ) then
 325                       goto 21
 326                     else
 327                       infare(larelo) = 0
 328                     endif
 329                   endif
 330   211           continue
 331 c
 332               endif
 333 c
 334    21       continue
 335 c
 336 c 2.2. ==> analyse
 337 c
 338 #ifdef _DEBUG_HOMARD_
 339             write (ulsort,*) '==> infare : ',infare
 340 #endif
 341             nbarpb = 0
 342 c
 343 c 2.2.1. ==> liste des aretes a traiter dans le cas du triangle
 344 c
 345             if ( option.eq.2 ) then
 346 c
 347               write (ulsort,*) 'pas glop'
 348               codret = 12
 349 c
 350 c 2.2.2. ==> liste des aretes a traiter dans le cas cas du quadrangle
 351 c            on explore les aretes par paire : on intervient quand
 352 c            deux aretes en vis-a-vis sont a garder ou qu'une arete a
 353 c            garder est en face d'une arete de bord.
 354 c
 355             else
 356 c
 357               do 222 , iaux = 1 , 2
 358 c
 359                 larelo = 0
 360                 if ( infare(iaux).eq.0 .and.
 361      >               infare(iaux+2).eq.-1 ) then
 362                   larelo = iaux
 363                 elseif ( infare(iaux).eq.-1 .and.
 364      >                   infare(iaux+2).eq.0 ) then
 365                   larelo = iaux+2
 366                 elseif ( infare(iaux).eq.0 .and.
 367      >                   infare(iaux+2).eq.0 ) then
 368                   larelo = iaux
 369                 endif
 370 c
 371                 if ( larelo.ne.0 ) then
 372                   nbarpb = nbarpb + 1
 373                   listar(nbarpb) = arequa(laface,larelo)
 374                 endif
 375 c
 376   222         continue
 377 c
 378             endif
 379 c
 380 c 2.2.3. ==> liste des faces voisines de ces aretes a traiter
 381 c
 382             if ( nbarpb.ne.0 ) then
 383 c
 384 #ifdef _DEBUG_HOMARD_
 385           write (ulsort,texte(langue,6)) mess14(langue,1,option),laface
 386           write (ulsort,*)(listar(iaux),iaux=1,nbarpb)
 387 #endif
 388 c
 389               do 223 , iaux = 1 , nbarpb
 390 c
 391                 larete = listar(iaux)
 392 c
 393 #ifdef _DEBUG_HOMARD_
 394           write (ulsort,texte(langue,7))'.. '//mess14(langue,1,1),
 395      > larete,decare(larete),hetare(larete)
 396 #endif
 397                 ideb = posifa(larete-1)+1
 398                 ifin = posifa(larete)
 399 c
 400                 do 2231 , ipos = ideb , ifin
 401                   iface = facare(ipos)
 402                   if ( iface.ne.faced) then
 403                     if ( iface.gt.0 ) then
 404                       etatfa = mod( hettri(iface) , 10 )
 405                     else
 406                       etatfa = mod( hetqua(-iface) , 100 )
 407 #ifdef _DEBUG_HOMARD_
 408           write (ulsort,texte(langue,7))'.... '//mess14(langue,1,4),
 409      > -iface,decfac(iface),hetqua(-iface)
 410 #endif
 411                     endif
 412                     if ( etatfa.ne.0 .and. decfac(iface).ne.-1 ) then
 413                       goto 223
 414                     else if ( decfac(iface).eq.4 ) then
 415                       goto 223
 416                     else
 417                       nbface = nbface + 1
 418                       listef(nbface) = iface
 419                     endif
 420                   endif
 421  2231           continue
 422 c
 423   223         continue
 424 c
 425             endif
 426 c
 427           endif
 428 c
 429    20   continue
 430 c
 431     2 continue
 432 c
 433 c====
 434 c 3. modification des decisions
 435 c    attention : il faut le faire seulement a la toute fin, sinon on
 436 c    risque de propager le raffinement
 437 c====
 438 #ifdef _DEBUG_HOMARD_
 439       write (ulsort,90002) '6. modifications decfac ; codret', codret
 440 #endif
 441 c
 442       if ( codret.eq.0 ) then
 443 c
 444       if ( nbface.ne.0 ) then
 445 c
 446         write (ulsort,texte(langue,5)) nbface
 447         afaire = 1
 448 c
 449 #ifdef _DEBUG_HOMARD_
 450       write (ulsort,*)(listef(iaux),iaux=1,nbface)
 451 #endif
 452 c
 453         do 31 , iaux = 1 , nbface
 454 c
 455           laface = listef(iaux)
 456           if ( decfac(laface).eq.0 ) then
 457             decfac(laface) = 4
 458           else
 459             decfac(laface) = 0
 460           endif
 461 #ifdef _DEBUG_HOMARD_
 462       write (ulsort,*)' '
 463       write (ulsort,texte(langue,30))'decfac', laface,decfac(laface),' '
 464 #endif
 465           nbaret = 0
 466           if ( laface.gt.0 ) then
 467             do 311 , larelo = 1 , 3
 468               larete = aretri(laface,larelo)
 469               if ( decare(larete).eq.0 .or. decare(larete).eq.-1 ) then
 470                 nbaret = nbaret + 1
 471                 infare(nbaret) = larete
 472               endif
 473   311       continue
 474           else
 475             do 312 , larelo = 1 , 4
 476               larete = arequa(-laface,larelo)
 477               if ( decare(larete).eq.0 .or. decare(larete).eq.-1 ) then
 478                 nbaret = nbaret + 1
 479                 infare(nbaret) = larete
 480               endif
 481   312       continue
 482           endif
 483 c
 484           do 313 , larelo = 1 , nbaret
 485             larete = infare(larelo)
 486             if ( decare(larete).eq.0 ) then
 487               if ( mod(hetare(larete),10).eq.0 ) then
 488                 decare(larete) = 2
 489               endif
 490             elseif ( decare(larete).eq.-1 ) then
 491               decare(larete) = 0
 492             endif
 493 #ifdef _DEBUG_HOMARD_
 494       write (ulsort,texte(langue,30))'decare', larete,decare(larete),' '
 495 #endif
 496   313     continue
 497 c
 498    31   continue
 499 c
 500       endif
 501 c
 502       endif
 503 c
 504 c====
 505 c 4. la fin
 506 c====
 507 c
 508       if ( codret.ne.0 ) then
 509 c
 510 #include "envex2.h"
 511 c
 512       write (ulsort,texte(langue,1)) 'Sortie', nompro
 513       write (ulsort,texte(langue,2)) codret
 514 c
 515       endif
 516 c
 517 #ifdef _DEBUG_HOMARD_
 518       write (ulsort,texte(langue,1)) 'Sortie', nompro
 519       call dmflsh (iaux)
 520 #endif
 521 c
 522       end