src/tool/Decision/decfs1.F

   1       subroutine decfs1 ( hettri, filtri,
   2      >                    hetqua, filqua,
   3      >                    hettet, filtet,
   4      >                    hethex, filhex, fhpyte,
   5      >                    hetpen, filpen, fppyte,
   6      >                    nbvtri, nbvqua,
   7      >                    nbvtet, nbvpyr,
   8      >                    trindr, trsupp,
   9      >                    quindr, qusupp,
  10      >                    teindr, tesupp,
  11      >                    heindr, hesupp,
  12      >                    pyindr, pysupp,
  13      >                    peindr, pesupp,
  14      >                    ulsort, langue, codret )
  15 c ______________________________________________________________________
  16 c
  17 c                             H O M A R D
  18 c
  19 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  20 c
  21 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  22 c aupres des huissiers de justice Simart et Lavoir a Clamart
  23 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  24 c aupres des huissiers de justice
  25 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  26 c
  27 c    HOMARD est une marque deposee d'Electricite de France
  28 c
  29 c Copyright EDF 1996
  30 c Copyright EDF 1998
  31 c Copyright EDF 2002
  32 c Copyright EDF 2020
  33 c ______________________________________________________________________
  34 c
  35 c traitement des DEcisions - mise en ConFormite - Suppression
  36 c                --                  -  -         -
  37 c                            des fils
  38 c   - usacmp = 0 : norme L2
  39 c   - usacmp = 1 : norme infinie
  40 c ______________________________________________________________________
  41 c On parcourt toutes les entites qui sont decoupees par conformite :
  42 c . si un indicateur d'erreur a ete defini sur au moins un des fils,
  43 c   on recupere la plus grande valeur
  44 c Remarque : decfs0 et decfs1 sont des clones
  45 c ______________________________________________________________________
  46 c .        .     .        .                                            .
  47 c .  nom   . e/s . taille .           description                      .
  48 c .____________________________________________________________________.
  49 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  50 c . filtri . e   . nbtrto . fils des triangles                         .
  51 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  52 c . filqua . e   . nbquto . premier fils des quadrangles               .
  53 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  54 c . filtet . e   . nbteto . premier fils des tetraedres                .
  55 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  56 c . filhex . e   . nbheto . fils des hexaedres                         .
  57 c . fhpyte . e   .2*nbhedc. fhpyte(1,j) = numero de la 1ere pyramide   .
  58 c .        .     .        . fille de l'hexaedre k tel que filhex(k) =-j.
  59 c .        .     .        . fhpyte(2,j) = numero du 1er tetraedre      .
  60 c .        .     .        . fils de l'hexaedre k tel que filhex(k) = -j.
  61 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  62 c . filpen . e   . nbpeto . premier fils des pentaedres                .
  63 c . fppyte . e   .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide   .
  64 c .        .     .        . fille du pentaedre k tel que filpen(k) = -j.
  65 c .        .     .        . fppyte(2,j) = numero du 1er tetraedre      .
  66 c .        .     .        . fils du pentaedre k tel que filpen(k) = -j .
  67 c . nbvpyr . e   .   1    . nombre de valeurs par pyramides            .
  68 c . nbvtet . e   .   1    . nombre de valeurs par tetraedres           .
  69 c . nbvqua . e   .   1    . nombre de valeurs par quadrangles          .
  70 c . nbvtri . e   .   1    . nombre de valeurs par triangles            .
  71 c . trsupp . e   . nbtrto . support pour les triangles                 .
  72 c . trindr . es  . nbtrto . valeurs reelles pour les triangles         .
  73 c . qusupp . e   . nbquto . support pour les quadrangles               .
  74 c . quindr . es  . nbquto . valeurs reelles pour les quadrangles       .
  75 c . tesupp . e   . nbteto . support pour les tetraedres                .
  76 c . teindr . es  . nbteto . valeurs reelles pour les tetraedres        .
  77 c . hesupp . e   . nbheto . support pour les hexaedres                 .
  78 c . heindr . es  . nbheto . valeurs reelles pour les hexaedres         .
  79 c . pysupp . e   . nbpyto . support pour les pyramides                 .
  80 c . pyindr . es  . nbpyto . valeurs reelles pour les pyramides         .
  81 c . pesupp . e   . nbpeto . support pour les pentaedres                .
  82 c . peindr . es  . nbpeto . valeurs reelles pour les pentaedres        .
  83 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  84 c . langue . e   .    1   . langue des messages                        .
  85 c .        .     .        . 1 : francais, 2 : anglais                  .
  86 c . codret . es  .    1   . code de retour des modules                 .
  87 c .        .     .        . 0 : pas de probleme                        .
  88 c .        .     .        . sinon : nombre de tetraedres a problemes   .
  89 c ______________________________________________________________________
  90 c
  91 c====
  92 c 0. declarations et dimensionnement
  93 c====
  94 c
  95 c 0.1. ==> generalites
  96 c
  97       implicit none
  98       save
  99 c
 100       character*6 nompro
 101       parameter ( nompro = 'DECFS1' )
 102 c
 103 #include "nblang.h"
 104 c
 105 c 0.2. ==> communs
 106 c
 107 #include "envex1.h"
 108 #include "infini.h"
 109 #include "impr02.h"
 110 c
 111 #include "nombtr.h"
 112 #include "nombqu.h"
 113 #include "nombte.h"
 114 #include "nombhe.h"
 115 #include "nombpy.h"
 116 #include "nombpe.h"
 117 #include "hexcf0.h"
 118 c
 119 c 0.3. ==> arguments
 120 c
 121       integer hettri(nbtrto), filtri(nbtrto)
 122       integer hetqua(nbquto), filqua(nbquto)
 123       integer hettet(nbteto), filtet(nbteto)
 124       integer hethex(nbheto), filhex(nbheto)
 125       integer fhpyte(2,nbheco)
 126       integer hetpen(nbpeto), filpen(nbpeto)
 127       integer fppyte(2,nbpeco)
 128       integer nbvtri, nbvqua
 129       integer nbvtet, nbvpyr
 130       integer trsupp(nbtrto)
 131       integer qusupp(nbquto)
 132       integer tesupp(nbteto)
 133       integer hesupp(nbheto)
 134       integer pysupp(nbpyto)
 135       integer pesupp(nbpeto)
 136 c
 137       integer ulsort, langue, codret
 138 c
 139       double precision trindr(nbtrto)
 140       double precision quindr(nbquto)
 141       double precision teindr(nbteto)
 142       double precision heindr(nbheto)
 143       double precision pyindr(nbpyto)
 144       double precision peindr(nbpeto)
 145 c
 146 c 0.4. ==> variables locales
 147 c
 148       integer iaux, jaux, kaux, laux
 149       integer fils
 150       integer nbte, nbte0, nbte1, nbte2, nbte3, nbte4, nbte5
 151       integer nbpy, nbpy0, nbpy1, nbpy2, nbpy3, nbpy4, nbpy5
 152       integer etat, bindec
 153 c
 154       double precision daux
 155 c
 156       logical yaconf
 157       logical yaintr, yainte, yainpy, yainqu
 158 c
 159       integer nbmess
 160       parameter ( nbmess = 10 )
 161       character*80 texte(nblang,nbmess)
 162 c
 163 c 0.5. ==> initialisations
 164 c ______________________________________________________________________
 165 c
 166 c====
 167 c 1. messages
 168 c====
 169 c
 170 #include "impr01.h"
 171 c
 172 #ifdef _DEBUG_HOMARD_
 173       write (ulsort,texte(langue,1)) 'Entree', nompro
 174       call dmflsh (iaux)
 175 #endif
 176 c
 177       texte(1,4) = '(''Suppression des conformites pour les '',a)'
 178 c
 179       texte(2,4) = '(''Suppression of the conformities for '',a)'
 180 c
 181 #include "impr03.h"
 182 c
 183       codret = 0
 184 c
 185 c====
 186 c 2. les triangles : transfert en presence d'indicateur d'erreurs
 187 c                    sur les fils de conformite
 188 c====
 189 c
 190 #ifdef _DEBUG_HOMARD_
 191       write (ulsort,texte(langue,4)) mess14(langue,3,2)
 192       write (ulsort,90002) 'nbvtri', nbvtri
 193 #endif
 194 c
 195       if ( nbvtri.gt.0 ) then
 196 c
 197         yaintr = .true.
 198 c
 199         do 20 , iaux = 1 , nbtrto
 200 c
 201           etat = mod( hettri(iaux), 10 )
 202 c
 203           if ( etat.ge.1 .and. etat.le.3 ) then
 204 cgn      write (ulsort,90015) 'Etat du '//mess14(langue,1,2), iaux,
 205 cgn     >                     ' : ',etat
 206 c
 207             daux = vinfne
 208             do 201 , kaux = 0, 1
 209               jaux = filtri(iaux) + kaux
 210               if ( trsupp(jaux).ne.0 ) then
 211                 daux = max(daux,abs(trindr(jaux)))
 212                 trsupp(iaux) = 1
 213               endif
 214   201       continue
 215 c
 216             if ( trsupp(iaux).ne.0 ) then
 217 cgn      write (ulsort,*) 'modif de trsupp(',iaux,'), valeur = ',daux
 218               trindr(iaux) = daux
 219             endif
 220 c
 221           endif
 222 c
 223    20   continue
 224 c
 225       else
 226 c
 227         yaintr = .false.
 228 c
 229       endif
 230 c
 231 c====
 232 c 3. les quadrangles : transfert en presence d'indicateur d'erreurs
 233 c====
 234 #ifdef _DEBUG_HOMARD_
 235       write (ulsort,*) '3. Quadrangles ; codret = ', codret
 236       write (ulsort,90002) 'nbvqua', nbvqua
 237 #endif
 238 c
 239       if ( nbquto.ne.0 ) then
 240 c
 241 #ifdef _DEBUG_HOMARD_
 242       write (ulsort,texte(langue,4)) mess14(langue,3,4)
 243 #endif
 244 c
 245         if ( nbvqua.gt.0 ) then
 246           yainqu = .true.
 247         else
 248           yainqu = .false.
 249         endif
 250 c
 251         if ( yainqu .or. yaintr ) then
 252 c
 253         do 30 , iaux = 1 , nbquto
 254 c
 255           etat = mod( hetqua(iaux), 100 )
 256 cgn      write (ulsort,90015) 'Etat du '//mess14(langue,1,4), iaux,
 257 cgn     >                     ' : ',etat
 258 c
 259 c 3.1. ==> les fils de conformite sont des quadrangles
 260 c
 261           if ( ( etat.eq.21 .or. etat.eq.22 .or.
 262      >         ( etat.ge.41 .and. etat.le.44 ) ) .and. yainqu ) then
 263 c
 264             daux = vinfne
 265             fils = filqua(iaux)
 266             if ( etat.eq.21 .or. etat.eq.22 ) then
 267               laux = 1
 268             else
 269               laux = 2
 270             endif
 271             do 301 , kaux = 0, laux
 272               jaux = fils + kaux
 273               if ( qusupp(jaux).ne.0 ) then
 274                 daux = max(daux,abs(quindr(jaux)))
 275                 qusupp(iaux) = 1
 276               endif
 277   301       continue
 278 c
 279             if ( qusupp(iaux).ne.0 ) then
 280               quindr(iaux) = daux
 281             endif
 282 c
 283 c 3.2. ==> les fils de conformite qui sont des triangles
 284 c
 285           elseif ( etat.ge.31 .and. etat.le.34 .and. yaintr ) then
 286 c
 287             daux = vinfne
 288             fils = -filqua(iaux)
 289             do 302 , kaux = 0, 2
 290               jaux = fils + kaux
 291               if ( trsupp(jaux).ne.0 ) then
 292                 daux = max(daux,abs(trindr(jaux)))
 293                 qusupp(iaux) = 1
 294               endif
 295   302       continue
 296 c
 297             if ( qusupp(iaux).ne.0 ) then
 298               quindr(iaux) = daux
 299             endif
 300 c
 301           endif
 302 c
 303    30   continue
 304 c
 305         endif
 306 c
 307       endif
 308 c
 309 c====
 310 c 4. les tetraedres : transfert en presence d'indicateur d'erreurs
 311 c                     sur les fils de conformite
 312 c====
 313 #ifdef _DEBUG_HOMARD_
 314       write (ulsort,*) '4. Tetraedres ; codret = ', codret
 315 #endif
 316 #ifdef _DEBUG_HOMARD_
 317       write (ulsort,texte(langue,4)) mess14(langue,3,3)
 318       write (ulsort,90002) 'nbvtet', nbvtet
 319 #endif
 320 c
 321       if ( nbvtet.gt.0 ) then
 322 c
 323         yainte = .true.
 324 c
 325         nbte1 = 1
 326         nbte2 = 3
 327 c
 328         do 40 , iaux = 1 , nbteto
 329 c
 330           etat = mod( hettet(iaux), 100 )
 331           yaconf = .false.
 332 cgn      write (ulsort,90015) 'Etat du '//mess14(langue,1,3), iaux,
 333 cgn     >                     ' : ',etat
 334 c
 335 c         nombre d'entites de conformite selon les modes de decoupage
 336 c
 337           if ( ( etat.ge.21 .and. etat.le.36 ) ) then
 338 c
 339             nbte = nbte1
 340             yaconf = .true.
 341 c
 342           elseif ( etat.ge.41 .and. etat.le.47 ) then
 343 c
 344             nbte = nbte2
 345             yaconf = .true.
 346 c
 347           endif
 348 c
 349           if ( yaconf ) then
 350 c
 351             daux = vinfne
 352             do 401 , kaux = 0, nbte
 353               jaux = filtet(iaux) + kaux
 354               if ( tesupp(jaux).ne.0 ) then
 355                 daux = max(daux,abs(teindr(jaux)))
 356 cgn      write (ulsort,*) '... valeur = ',daux
 357                 tesupp(iaux) = 1
 358               endif
 359   401       continue
 360 c
 361             if ( tesupp(iaux).ne.0 ) then
 362 cgn      write (ulsort,*) 'modif de tesupp(',iaux,'), valeur = ',daux
 363               teindr(iaux) = daux
 364             endif
 365 c
 366           endif
 367 c
 368    40   continue
 369 c
 370       else
 371 c
 372         yainte = .false.
 373 c
 374       endif
 375 c
 376 c====
 377 c 5. les pyramides : pas de transfert car pas de decoupage mais
 378 c                    reperage de la presence d'indicateurs
 379 c====
 380 #ifdef _DEBUG_HOMARD_
 381       write (ulsort,*) '5. pyramides ; codret = ', codret
 382 #endif
 383 #ifdef _DEBUG_HOMARD_
 384       write (ulsort,texte(langue,4)) mess14(langue,3,5)
 385       write (ulsort,90002) 'nbvpyr', nbvpyr
 386 #endif
 387 c
 388       if ( nbvpyr.gt.0 ) then
 389 c
 390         yainpy = .true.
 391 c
 392       else
 393 c
 394         yainpy = .false.
 395 c
 396       endif
 397 c
 398 c====
 399 c 6. les hexaedres
 400 c====
 401 #ifdef _DEBUG_HOMARD_
 402       write (ulsort,*) '6. Hexaedres ; codret = ', codret
 403 #endif
 404 c
 405       if ( nbheto.ne.0 .and. ( yainte .or. yainpy ) ) then
 406 c
 407 #ifdef _DEBUG_HOMARD_
 408       write (ulsort,texte(langue,4)) mess14(langue,3,6)
 409       write (ulsort,90002) 'nbvtet', nbvtet
 410       write (ulsort,90002) 'nbvpyr', nbvpyr
 411 #endif
 412 c
 413         do 60 , iaux = 1 , nbheto
 414 c
 415           etat = mod(hethex(iaux),1000)
 416 #ifdef _DEBUG_HOMARD_
 417       write (ulsort,90015) 'Etat du '//mess14(langue,1,6), iaux,
 418      >                     ' : ',etat
 419 #endif
 420 c
 421 c        nombre d'entites de conformite selon les modes de decoupage
 422 c
 423           if ( etat.ge.11 ) then
 424 c
 425             bindec = chbiet(etat)
 426 #ifdef _DEBUG_HOMARD_
 427       write (ulsort,90015) 'etat', etat, ' ==> code binaire', bindec
 428 #endif
 429 c
 430             if ( nbvpyr.gt.0 ) then
 431               nbpy = chnpy(bindec)
 432             else
 433               nbpy = -1
 434             endif
 435             if ( nbvtet.gt.0 ) then
 436               nbte = chnte(bindec)
 437             else
 438               nbte = -1
 439             endif
 440             yaconf = .true.
 441 c
 442           else
 443 c
 444             yaconf = .false.
 445 c
 446           endif
 447 c
 448           if ( yaconf ) then
 449 #ifdef _DEBUG_HOMARD_
 450       write (ulsort,90002) '... nbpy/nbte', nbpy, nbte
 451 #endif
 452 c
 453             daux = vinfne
 454 c
 455             fils = fhpyte(1,-filhex(iaux))
 456 cgn      write (ulsort,*) '.. fils pyramide = ', fils
 457             do 601 , kaux = 1, nbpy
 458 cgn      write (ulsort,*) '.... pyramide ', fils, pysupp(fils)
 459               if ( pysupp(fils).ne.0 ) then
 460 cgn      write (ulsort,*) '.... ', fils, pyindr(fils)
 461                 daux = max(daux,abs(pyindr(fils)))
 462                 hesupp(iaux) = 1
 463               endif
 464               fils = fils + 1
 465   601       continue
 466 c
 467             fils = fhpyte(2,-filhex(iaux))
 468 cgn      write (ulsort,*) '.. fils tetraedre = ', fils
 469             do 602 , kaux = 1, nbte
 470 cgn      write (ulsort,*) '.... tetraedre ', fils, tesupp(fils)
 471               if ( tesupp(fils).ne.0 ) then
 472                 daux = max(daux,abs(teindr(fils)))
 473                 hesupp(iaux) = 1
 474               endif
 475               fils = fils + 1
 476   602       continue
 477 c
 478             if ( hesupp(iaux).ne.0 ) then
 479 cgn      write (ulsort,*) 'modif de hesupp(',iaux,'), valeur = ',daux
 480               heindr(iaux) = daux
 481             endif
 482 c
 483           endif
 484 c
 485    60   continue
 486 c
 487       endif
 488 c
 489 c====
 490 c 7. les pentaedres
 491 c====
 492 #ifdef _DEBUG_HOMARD_
 493       write (ulsort,*) '7. Pentaedres ; codret = ', codret
 494 #endif
 495 c
 496       if ( nbpeto.ne.0 .and. ( yainte .or. yainpy ) ) then
 497 c
 498 #ifdef _DEBUG_HOMARD_
 499       write (ulsort,texte(langue,4)) mess14(langue,3,7)
 500       write (ulsort,90002) 'nbvtet', nbvtet
 501       write (ulsort,90002) 'nbvpyr', nbvpyr
 502 #endif
 503 c
 504         if ( nbvtet.gt.0 ) then
 505           nbte0 = 0
 506           nbte1 = 1
 507           nbte2 = 5
 508           nbte3 = 9
 509           nbte4 = 1
 510           nbte5 = 10
 511         else
 512           nbte0 = -1
 513           nbte1 = -1
 514           nbte2 = -1
 515           nbte3 = -1
 516           nbte4 = -1
 517           nbte5 = -1
 518         endif
 519 c
 520         if ( nbvpyr.gt.0 ) then
 521           nbpy0 = 1
 522           nbpy1 = 0
 523           nbpy2 = -1
 524           nbpy3 = 0
 525           nbpy4 = 3
 526           nbpy5 = -1
 527         else
 528           nbpy0 = -1
 529           nbpy1 = -1
 530           nbpy2 = -1
 531           nbpy3 = -1
 532           nbpy4 = -1
 533           nbpy5 = -1
 534         endif
 535 c
 536         do 70 , iaux = 1 , nbpeto
 537 c
 538           etat = mod( hetpen(iaux), 100 )
 539 #ifdef _DEBUG_HOMARD_
 540       write (ulsort,90015) 'Etat du '//mess14(langue,1,7), iaux,
 541      >                     ' : ',etat
 542 #endif
 543 c
 544           yaconf = .false.
 545           if ( ( etat.ge. 1 .and. etat.le.6 ) ) then
 546 c
 547             nbpy = nbpy0
 548             nbte = nbte0
 549             yaconf = .true.
 550 c
 551           elseif ( ( etat.ge.17 .and. etat.le.19 ) ) then
 552 c
 553             nbpy = nbpy1
 554             nbte = nbte1
 555             yaconf = .true.
 556 c
 557           elseif ( etat.ge.21 .and. etat.le.26 ) then
 558 c
 559             nbpy = nbpy2
 560             nbte = nbte2
 561             yaconf = .true.
 562 c
 563           elseif ( etat.ge.31 .and. etat.le.36 ) then
 564 c
 565             nbpy = nbpy3
 566             nbte = nbte3
 567             yaconf = .true.
 568 c
 569           elseif ( etat.ge.43 .and. etat.le.45 ) then
 570 c
 571             nbpy = nbpy4
 572             nbte = nbte4
 573             yaconf = .true.
 574 c
 575           elseif ( etat.ge.51 .and. etat.le.52 ) then
 576 c
 577             nbpy = nbpy5
 578             nbte = nbte5
 579             yaconf = .true.
 580 c
 581           endif
 582 c
 583           if ( yaconf ) then
 584 c
 585 #ifdef _DEBUG_HOMARD_
 586       write (ulsort,90002) '... nbpy/nbte', nbpy, nbte
 587 #endif
 588 c
 589             daux = vinfne
 590 c
 591             fils = fppyte(1,-filpen(iaux))
 592 cgn      write (ulsort,*) '.. fils pyramide = ', fils
 593             do 701 , kaux = 0, nbpy
 594               jaux = fils + kaux
 595 cgn      write (ulsort,*) '.... pyramide ', jaux, pysupp(jaux)
 596               if ( pysupp(jaux).ne.0 ) then
 597 cgn      write (ulsort,*) '.... ', jaux, pyindr(jaux)
 598                 daux = max(daux,abs(pyindr(jaux)))
 599                 pesupp(iaux) = 1
 600               endif
 601   701       continue
 602 c
 603             fils = fppyte(2,-filpen(iaux))
 604 cgn      write (ulsort,*) '.. fils tetraedre = ', fils
 605             do 702 , kaux = 0, nbte
 606               jaux = fils + kaux
 607               if ( tesupp(jaux).ne.0 ) then
 608 cgn       write (ulsort,*) '.... ', jaux, teindr(jaux)
 609                 daux = max(daux,abs(teindr(jaux)))
 610                 pesupp(iaux) = 1
 611               endif
 612   702       continue
 613 c
 614             if ( pesupp(iaux).ne.0 ) then
 615 cgn      write (ulsort,*) 'modif de pesupp(',iaux,'), valeur = ',daux
 616               peindr(iaux) = daux
 617             endif
 618 c
 619           endif
 620 c
 621    70   continue
 622 c
 623       endif
 624 c
 625 c====
 626 c 8. la fin
 627 c====
 628 c
 629       if ( codret.ne.0 ) then
 630 c
 631 #include "envex2.h"
 632 c
 633       write (ulsort,texte(langue,1)) 'Sortie', nompro
 634       write (ulsort,texte(langue,2)) codret
 635       write (ulsort,texte(langue,6)) codret
 636 c
 637       endif
 638 c
 639 #ifdef _DEBUG_HOMARD_
 640       write (ulsort,texte(langue,1)) 'Sortie', nompro
 641       call dmflsh (iaux)
 642 #endif
 643 c
 644       end