src/tool/Decision/deinfi.F

   1       subroutine deinfi ( option, obfiad,
   2      >                    decare, decfac, iniada,
   3      >                    filtar, filtfa,
   4      >                    povoso, voisom,
   5      >                    noempo,
   6      >                    somare,
   7      >                    aretri,
   8      >                    arequa,
   9      >                    tritet,
  10      >                    quahex,
  11      >                    facpyr,
  12      >                    facpen,
  13      >                    ulsort, langue, codret )
  14 c ______________________________________________________________________
  15 c
  16 c                             H O M A R D
  17 c
  18 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  19 c
  20 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  21 c aupres des huissiers de justice Simart et Lavoir a Clamart
  22 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  23 c aupres des huissiers de justice
  24 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  25 c
  26 c    HOMARD est une marque deposee d'Electricite de France
  27 c
  28 c Copyright EDF 1996
  29 c Copyright EDF 1998
  30 c Copyright EDF 2002
  31 c Copyright EDF 2020
  32 c ______________________________________________________________________
  33 c
  34 c traitement des DEcisions - INitialisations - FIltrage
  35 c                --          --                --
  36 c ______________________________________________________________________
  37 c  Modification des decisions pour tenir compte du filtrage
  38 c ______________________________________________________________________
  39 c .        .     .        .                                            .
  40 c .  nom   . e/s . taille .           description                      .
  41 c .____________________________________________________________________.
  42 c . option . e   .    1   . 0 : on retire les entites filtrees         .
  43 c .        .     .        . 1 : on ajoute les entites filtrees         .
  44 c . obfiad . e   . char*8 . memorisation du filtrage de l'adaptation   .
  45 c . decare . es  .0:nbarto. decisions des aretes                       .
  46 c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
  47 c .        .     . :nbtrto.                                            .
  48 c . iniada . e   .   1    . initialisation de l'adaptation             .
  49 c .        .     .        . 0 : on garde tout (defaut)                 .
  50 c .        .     .        .-1 : reactivation des mailles ou aucun      .
  51 c .        .     .        .     indicateur n'est defini                .
  52 c .        .     .        . 1 : raffinement des mailles ou aucun       .
  53 c .        .     .        .     indicateur n'est defini                .
  54 c . filtar .  a  . nbarto . filtrage des aretes                        .
  55 c . filtfa .  a  . -nbquto. filtrage sur les faces (quad. + tri.)      .
  56 c .        .     . :nbtrto.                                            .
  57 c . povoso . e   .0:nbnoto. pointeur des voisins par sommet            .
  58 c . voisom . e   . nvosom . aretes voisines de chaque noeud            .
  59 c . noempo . e   . nbmpto . numeros des noeuds associes aux mailles    .
  60 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  61 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  62 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  63 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  64 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  65 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  66 c . facpen . e   .nbpecf*5. numeros des faces des pentaedres           .
  67 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  68 c . langue . e   .    1   . langue des messages                        .
  69 c .        .     .        . 1 : francais, 2 : anglais                  .
  70 c . codret . es  .    1   . code de retour des modules                 .
  71 c .        .     .        . 0 : pas de probleme                        .
  72 c ______________________________________________________________________
  73 c
  74 c====
  75 c 0. declarations et dimensionnement
  76 c====
  77 c
  78 c 0.1. ==> generalites
  79 c
  80       implicit none
  81       save
  82 c
  83       character*6 nompro
  84       parameter ( nompro = 'DEINFI' )
  85 c
  86 #include "nblang.h"
  87 c
  88 c 0.2. ==> communs
  89 c
  90 #include "envex1.h"
  91 #include "gmenti.h"
  92 #include "nombno.h"
  93 #include "nombmp.h"
  94 #include "nombar.h"
  95 #include "nombtr.h"
  96 #include "nombqu.h"
  97 #include "nombte.h"
  98 #include "nombhe.h"
  99 #include "nombpy.h"
 100 #include "nombpe.h"
 101 c
 102 #include "impr02.h"
 103 c
 104 c 0.3. ==> arguments
 105 c
 106       integer option
 107 c
 108       character*8 obfiad
 109 c
 110       integer decare(0:nbarto), decfac(-nbquto:nbtrto)
 111       integer iniada
 112       integer filtar(nbarto), filtfa(-nbquto:nbtrto)
 113       integer povoso(0:nbnoto), voisom(*)
 114       integer noempo(nbmpto)
 115       integer somare(2,nbarto)
 116       integer aretri(nbtrto,3)
 117       integer arequa(nbquto,4)
 118       integer tritet(nbtecf,4)
 119       integer quahex(nbhecf,6)
 120       integer facpyr(nbpycf,5)
 121       integer facpen(nbpecf,5)
 122 c
 123       integer ulsort, langue, codret
 124 c
 125 c 0.4. ==> variables locales
 126 c
 127       integer iaux, jaux, kaux, laux
 128       integer kdeb, kfin
 129       integer larete, lesomm
 130       integer nbvent, adfilt
 131       integer typenh
 132       integer valdef, valmod
 133       integer nbpass
 134 c
 135       character*5 saux
 136 c
 137       integer nbmess
 138       parameter ( nbmess = 10 )
 139       character*80 texte(nblang,nbmess)
 140 c
 141 c 0.5. ==> initialisations
 142 c
 143       data nbpass / 0 /
 144 c ______________________________________________________________________
 145 c
 146 c====
 147 c 1. Initialisations
 148 c====
 149 c
 150 #include "impr01.h"
 151 c
 152 #ifdef _DEBUG_HOMARD_
 153       write (ulsort,texte(langue,1)) 'Entree', nompro
 154       call dmflsh (iaux)
 155 #endif
 156 c
 157 c 1.1. ==> Les messages
 158 c
 159       texte(1,4) = '(5x,''Filtrage'',i2)'
 160       texte(1,5) = '(5x,''Retrait des entites filtrees'')'
 161       texte(1,6) = '(5x,''Ajout des entites filtrees'')'
 162       texte(1,7) = '(''Filtrage pour les '',a)'
 163 c
 164       texte(2,4) = '(5x,''Filtering #'',i2)'
 165       texte(2,5) = '(5x,''Removal of filtered entities'')'
 166       texte(2,6) = '(5x,''Addition of filtered entities'')'
 167       texte(2,7) = '(''Filtering for the '',a)'
 168 c
 169 #include "impr03.h"
 170 c
 171       nbpass = nbpass + 1
 172 #ifdef _DEBUG_HOMARD_
 173       write (ulsort,texte(langue,4)) nbpass
 174       write (ulsort,texte(langue,5+option))
 175 #endif
 176 c
 177       codret = 0
 178 c
 179 c 1.2. ==> Au depart rien n'est retenu
 180 c
 181       if ( option.eq.0 ) then
 182         valdef = 1
 183         valmod = 0
 184       elseif ( option.eq.1 ) then
 185         valdef = 0
 186         valmod = 1
 187       else
 188         codret = 1
 189       endif
 190 #ifdef _DEBUG_HOMARD_
 191       write (ulsort,90002) 'option', option
 192       write (ulsort,90002) 'valdef', valdef
 193       write (ulsort,90002) 'valmod', valmod
 194 #endif
 195 c
 196       if ( codret.eq.0 ) then
 197 c
 198       do 121 , iaux = 1 , nbarto
 199         filtar(iaux) = valdef
 200   121 continue
 201 c
 202       do 122 , iaux = -nbquto , nbtrto
 203         filtfa(iaux) = valdef
 204   122 continue
 205 c
 206       endif
 207 c
 208 c====
 209 c 2. Boucle sur tous les types d'entites mailles (cf. vcfia0)
 210 c====
 211 cgn      write (ulsort,90003) 'obfiad', obfiad
 212 #ifdef _DEBUG_HOMARD_
 213       call gmprsx ( nompro, obfiad )
 214 #endif
 215 c
 216       do 21 , typenh = -1 , 7
 217 c
 218 c 2.1. ==> Nombre de valeurs
 219 c
 220         if ( codret.eq.0 ) then
 221 c
 222         iaux = typenh + 2
 223         call gmliat ( obfiad, iaux, nbvent, codret )
 224 c
 225         endif
 226 c
 227 c 2.2. ==> Adresse des valeurs s'il y en a
 228 c
 229         if ( codret.eq.0 ) then
 230 c
 231         if ( nbvent.gt.0 ) then
 232 c
 233 #ifdef _DEBUG_HOMARD_
 234           write (ulsort,texte(langue,7)) mess14(langue,3,typenh)
 235 #endif
 236 c
 237           if ( codret.eq.0 ) then
 238 c
 239           iaux = typenh + 2
 240           call utench ( iaux, 'g', jaux, saux,
 241      >                  ulsort, langue, codret )
 242 c
 243           endif
 244 c
 245           if ( codret.eq.0 ) then
 246 c
 247           saux = '.Tab'//saux(1:1)
 248           call gmadoj ( obfiad//saux, adfilt, iaux, codret )
 249           adfilt = adfilt - 1
 250 c
 251           endif
 252 c
 253         endif
 254 c
 255         endif
 256 c
 257 c 2.3. ==> Prise en compte selon le type de mailles
 258 c          On boucle sur le nombre de mailles courantes. Ce n'est pas
 259 c          toujours egal au nombre de valeurs du fait de la suppression
 260 c          eventuelle de mailles de mise en conformite. Ce n'est pas
 261 c          grave car dans la creation de obfiad (vcfiad), on a pris en
 262 c          compte toutes les entites, quel que soit leur statut.
 263 #ifdef _DEBUG_HOMARD_
 264       write (ulsort,90002) '2.3. '//mess14(langue,3,typenh)//' codret',
 265      >                     codret
 266 #endif
 267 c
 268         if ( codret.eq.0 ) then
 269 c
 270         if ( nbvent.gt.0 ) then
 271 c
 272 #ifdef _DEBUG_HOMARD_
 273           call gmprsx ( nompro, obfiad//saux )
 274 #endif
 275 c
 276 c 2.3.1. ==> Les sommets : on traite les aretes dont les deux
 277 c                          extremites sont dans le filtre
 278 c
 279           if ( typenh.eq.-1 ) then
 280 c
 281             do 231 , iaux = 1 , nbarto
 282               if ( imem(adfilt+somare(1,iaux)).ne.0 .and.
 283      >             imem(adfilt+somare(2,iaux)).ne.0 ) then
 284 cgn                write (ulsort,90002) 'arete ', iaux
 285                 filtar(iaux) = valmod
 286               endif
 287   231       continue
 288 c
 289 c 2.3.2. ==> Les mailles-points :
 290 c            Pour une maille-point retenue, on parcourt toutes les
 291 c            aretes qui ont le noeud sous-jacent pour extremite. Pour
 292 c            chacune de ces aretes, on regarde l'autre sommet. Si une
 293 c            maille-point retenue est basee sur cet autre sommet, on
 294 c            declare l'arete comme faisant partie des candidats a
 295 c            l'adaptation.
 296 c            Remarque : il n'est pas trop grave de faire la double
 297 c                       boucle car il y a peu de mailles-points !
 298 c
 299           elseif ( typenh.eq.0 ) then
 300 c
 301             do 232 , iaux = 1 , nbmpto
 302 c
 303               if ( imem(adfilt+iaux).ne.0 ) then
 304 c
 305                 jaux = noempo(iaux)
 306                 kdeb = povoso(jaux-1) + 1
 307                 kfin = povoso(jaux)
 308 c
 309                 do 2321 , kaux = kdeb, kfin
 310                   larete = voisom(kaux)
 311                   if ( somare(1,larete).eq.jaux ) then
 312                     lesomm = somare(2,larete)
 313                   else
 314                     lesomm = somare(1,larete)
 315                   endif
 316                   do 23211 , laux = 1 , nbmpto
 317                     if ( noempo(laux).eq.lesomm ) then
 318                       if ( imem(adfilt+laux).ne.0 ) then
 319                         filtar(larete) = valmod
 320                         goto 232
 321                       endif
 322                     endif
 323 23211           continue
 324  2321           continue
 325 c
 326               endif
 327 c
 328   232       continue
 329 c
 330 c 2.3.3. ==> Les aretes : chacune est traitee
 331 c
 332           elseif ( typenh.eq.1 ) then
 333 c
 334             do 233 , iaux = 1 , nbarto
 335 cgn                write (ulsort,90002) 'arete ', iaux
 336               if ( imem(adfilt+iaux).ne.0 ) then
 337 cgn                write (ulsort,90002) '==> passage a', valmod
 338                 filtar(iaux) = valmod
 339               endif
 340   233       continue
 341 c
 342 c 2.3.4. ==> Les triangles : chacun est traite, de meme que ses aretes
 343 c
 344           elseif ( typenh.eq.2 ) then
 345 c
 346             do 234 , iaux = 1 , nbtrto
 347 cgn      write (ulsort,90002) 'triangle ', iaux,imem(adfilt+iaux),decfac(iaux)
 348               if ( imem(adfilt+iaux).ne.0 ) then
 349 cgn                write (ulsort,90002) '==> passage a', valmod
 350 cgn      write (ulsort,90002) '==> modif aretes', (aretri(iaux,jaux),jaux=1,3)
 351                 filtfa(iaux) = valmod
 352                 filtar(aretri(iaux,1)) = valmod
 353                 filtar(aretri(iaux,2)) = valmod
 354                 filtar(aretri(iaux,3)) = valmod
 355               endif
 356   234       continue
 357 c
 358 c 2.3.5. ==> Les tetraedres : chacune de ses faces et de ses aretes est
 359 c                             traitee
 360 c
 361           elseif ( typenh.eq.3 ) then
 362 c
 363             do 235 , iaux = 1 , nbteto
 364 cgn         print *,'tetr',iaux,imem(adfilt+iaux)
 365               if ( imem(adfilt+iaux).ne.0 ) then
 366                 do 2351 , jaux = 1 , 4
 367                   kaux = tritet(iaux,jaux)
 368                   filtfa(kaux) = valmod
 369                   filtar(aretri(kaux,1)) = valmod
 370                   filtar(aretri(kaux,2)) = valmod
 371                   filtar(aretri(kaux,3)) = valmod
 372  2351           continue
 373               endif
 374   235       continue
 375 c
 376 c 2.3.6. ==> Les quadrangles : chacun est traite, de meme que ses aretes
 377 c
 378           elseif ( typenh.eq.4 ) then
 379 c
 380             do 236 , iaux = 1 , nbquto
 381               if ( imem(adfilt+iaux).ne.0 ) then
 382                 filtfa(-iaux) = valmod
 383                 filtar(arequa(iaux,1)) = valmod
 384                 filtar(arequa(iaux,2)) = valmod
 385                 filtar(arequa(iaux,3)) = valmod
 386                 filtar(arequa(iaux,4)) = valmod
 387               endif
 388   236       continue
 389 c
 390 c 2.3.7. ==> Les pyramides : chacune de ses faces et de ses aretes est
 391 c                            traitee
 392 c          Remarque : comme on affecte valmod a toutes les aretes des
 393 c                     triangles, il est inutile de se preoccuper des
 394 c                     aretes du quadrangle car elles sont deja traitees
 395 c
 396           elseif ( typenh.eq.5 ) then
 397 c
 398             do 237 , iaux = 1 , nbpyto
 399               if ( imem(adfilt+iaux).ne.0 ) then
 400                 do 2371 , jaux = 1 , 4
 401                   kaux = facpyr(iaux,jaux)
 402                   filtfa(kaux) = valmod
 403                   filtar(aretri(kaux,1)) = valmod
 404                   filtar(aretri(kaux,2)) = valmod
 405                   filtar(aretri(kaux,3)) = valmod
 406  2371           continue
 407                 kaux = facpyr(iaux,5)
 408                 filtfa(-kaux) = valmod
 409               endif
 410   237       continue
 411 c
 412 c 2.3.8. ==> Les hexaedres : chacune de ses faces et de ses aretes est
 413 c                            traitee
 414 c
 415           elseif ( typenh.eq.6 ) then
 416 c
 417             do 238 , iaux = 1 , nbheto
 418               if ( imem(adfilt+iaux).ne.0 ) then
 419 cgn                write(*,*)'.. hexaedre', iaux
 420                 do 2381 , jaux = 1 , 6
 421                   kaux = quahex(iaux,jaux)
 422                   filtfa(-kaux) = valmod
 423                   filtar(arequa(kaux,1)) = valmod
 424                   filtar(arequa(kaux,2)) = valmod
 425                   filtar(arequa(kaux,3)) = valmod
 426                   filtar(arequa(kaux,4)) = valmod
 427 cgn                  write(*,*)'.... face', kaux
 428  2381           continue
 429               endif
 430   238       continue
 431 c
 432 c 2.3.9. ==> Les pentaedres : chacune de ses faces et de ses aretes est
 433 c                             traitee
 434 c          Remarque : comme on affecte valmod a toutes les aretes des
 435 c                     quadrangles, il est inutile de se preoccuper des
 436 c                     aretes des triangles car elles sont deja traitees
 437 c
 438           elseif ( typenh.eq.7 ) then
 439 c
 440             do 239 , iaux = 1 , nbpeto
 441 cgn              write(ulsort,*)'.... pentaedre', iaux
 442               if ( imem(adfilt+iaux).ne.0 ) then
 443                 do 2391 , jaux = 1 , 2
 444                   kaux = facpen(iaux,jaux)
 445                   filtfa(kaux) = valmod
 446  2391           continue
 447                 do 2392 , jaux = 3 , 5
 448                   kaux = facpen(iaux,jaux)
 449 cgn                  write(ulsort,*)'.... face', kaux
 450 cgn                  write(ulsort,*)'.... aretes', arequa(kaux,1),
 451 cgn     >            arequa(kaux,2),arequa(kaux,3),arequa(kaux,4)
 452                   filtfa(-kaux) = valmod
 453                   filtar(arequa(kaux,1)) = valmod
 454                   filtar(arequa(kaux,2)) = valmod
 455                   filtar(arequa(kaux,3)) = valmod
 456                   filtar(arequa(kaux,4)) = valmod
 457  2392           continue
 458               endif
 459   239       continue
 460 c
 461           endif
 462 c
 463         endif
 464 c
 465         endif
 466 c
 467    21 continue
 468 c
 469 c====
 470 c 3. Applications aux decisions
 471 c====
 472 #ifdef _DEBUG_HOMARD_
 473       write (ulsort,90002) '3. Applications ; codret', codret
 474 #endif
 475 c
 476       if ( codret.eq.0 ) then
 477 c
 478       if ( iniada.eq.1 ) then
 479         valmod = 2
 480       else
 481         valmod = iniada
 482       endif
 483 c
 484       do 31 , iaux = 1 , nbarto
 485         if ( filtar(iaux).eq.0 ) then
 486 cgn          if ( decare(iaux).gt.0 ) then
 487 cgn        write(ulsort,*)'    suppression pour arete', iaux
 488             decare(iaux) = valmod
 489 cgn          endif
 490         endif
 491    31 continue
 492 c
 493       if ( iniada.eq.1 ) then
 494         valmod = 4
 495       else
 496         valmod = iniada
 497       endif
 498 c
 499       do 32 , iaux = -nbquto , nbtrto
 500         if ( filtfa(iaux).eq.0 ) then
 501 cgn          if ( decfac(iaux).gt.0 ) then
 502             decfac(iaux) = valmod
 503 cgn          endif
 504         endif
 505    32 continue
 506 c
 507       endif
 508 c
 509 c====
 510 c 4. la fin
 511 c====
 512 c
 513       if ( codret.ne.0 ) then
 514 c
 515 #include "envex2.h"
 516 c
 517       write (ulsort,texte(langue,1)) 'Sortie', nompro
 518       write (ulsort,texte(langue,2)) codret
 519 c
 520       endif
 521 c
 522 #ifdef _DEBUG_HOMARD_
 523       write (ulsort,texte(langue,1)) 'Sortie', nompro
 524       call dmflsh (iaux)
 525 #endif
 526 c
 527       end