src/tool/Decision/decfs0.F

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