src/tool/Decision/deinri.F

   1       subroutine deinri ( pilraf, pilder,
   2      >                    typseh, typseb, seuilh, seuilb, nbsoci,
   3      >                    usacmp,
   4      >                    nbvpen, nbvpyr, nbvhex, nbvtet,
   5      >                    nbvqua, nbvtri, nbvare, nbvnoe,
   6      >                    nosupp, noindr, noindi,
   7      >                    arsupp, arindr, arindi,
   8      >                    trsupp, trindr, trindi,
   9      >                    qusupp, quindr, quindi,
  10      >                    tesupp, teindr, teindi,
  11      >                    hesupp, heindr, heindi,
  12      >                    pysupp, pyindr, pyindi,
  13      >                    pesupp, peindr, peindi,
  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 - INitialisation de l'indicateur
  36 c                --          --
  37 c                                passage de Reel a entIer
  38 c                                           -         -
  39 c ______________________________________________________________________
  40 c
  41 c remarque : il faut filtrer par les supports pour les endroits ou
  42 c            la valeur de l'indicateur est indefinie. mettre une
  43 c            valeur "moyenne" ne permet pas de passer certains cas
  44 c            biscornus a cause des .le. ou .lt.
  45 c ______________________________________________________________________
  46 c .        .     .        .                                            .
  47 c .  nom   . e/s . taille .           description                      .
  48 c .____________________________________________________________________.
  49 c . pilraf . e   .   1    . pilotage du raffinement                    .
  50 c .        .     .        . -1 : raffinement uniforme                  .
  51 c .        .     .        .  0 : pas de raffinement                    .
  52 c .        .     .        .  1 : raffinement libre                     .
  53 c .        .     .        .  2 : raff. libre homogene en type d'element.
  54 c . pilder . e   .   1    . pilotage du deraffinement                  .
  55 c .        .     .        . 0 : pas de deraffinement                   .
  56 c .        .     .        . 1 : deraffinement libre                    .
  57 c .        .     .        . -1 : deraffinement uniforme                .
  58 c . typseh . e   .   1    . type de seuil haut                         .
  59 c .        .     .        . 1 : absolu                                 .
  60 c .        .     .        . 2 : relatif                                .
  61 c .        .     .        . 3 : pourcentage d'entites                  .
  62 c .        .     .        . 4 : moyenne + nh*ecart-type                .
  63 c .        .     .        . 5 : cible en nombre de noeuds              .
  64 c . typseb . e   .   1    . type de seuil bas                          .
  65 c .        .     .        . 1 : absolu                                 .
  66 c .        .     .        . 2 : relatif                                .
  67 c .        .     .        . 3 : pourcentage d'entites                  .
  68 c .        .     .        . 4 : moyenne - nb*ecart-type                .
  69 c . seuilh . es  .   1    . borne superieure de l'erreur (absolue,     .
  70 c .        .     .        . relatif, pourcentage d'entites ou nh)      .
  71 c . seuilb . e   .   1    . borne inferieure de l'erreur (absolue,     .
  72 c .        .     .        . relatif, pourcentage d'entites ou nb)      .
  73 c . nbsoci . e   .   1    . cible en nombre de sommets  (-1 si non)    .
  74 c . usacmp . e   .   1    . usage des composantes de l'indicateur      .
  75 c .        .     .        . 0 : norme L2                               .
  76 c .        .     .        . 1 : norme infinie -max des valeurs absolues.
  77 c .        .     .        . 2 : valeur relative si une seule composante.
  78 c . nbvpen . e   .   1    . nombre de valeurs par pentaedres           .
  79 c . nbvpyr . e   .   1    . nombre de valeurs par pyramides            .
  80 c . nbvhex . e   .   1    . nombre de valeurs par hexaedres            .
  81 c . nbvtet . e   .   1    . nombre de valeurs par tetraedres           .
  82 c . nbvqua . e   .   1    . nombre de valeurs par quadrangles          .
  83 c . nbvtri . e   .   1    . nombre de valeurs par triangles            .
  84 c . nbvare . e   .   1    . nombre de valeurs par aretes               .
  85 c . nbvnoe . e   .   1    . nombre de valeurs par noeuds               .
  86 c . nosupp . e   . nbnoto . support pour les noeuds                    .
  87 c . noindr . e   . nbnoto . valeurs reelles pour les noeuds            .
  88 c . noindi .  s  . nbnoto . valeurs entieres pour les noeuds           .
  89 c . arsupp . e   . nbarto . support pour les aretes                    .
  90 c . arindr . es  . nbarto . valeurs reelles pour les aretes            .
  91 c . arindi .  s  . nbarto . valeurs entieres pour les aretes           .
  92 c . trsupp . e   . nbtrto . support pour les triangles                 .
  93 c . trindr . es  . nbtrto . valeurs reelles pour les triangles         .
  94 c . trindi .  s  . nbtrto . valeurs entieres pour les triangles        .
  95 c . qusupp . e   . nbquto . support pour les quadrangles               .
  96 c . quindr . es  . nbquto . valeurs reelles pour les quadrangles       .
  97 c . quindi .  s  . nbquto . valeurs entieres pour les quadrangles      .
  98 c . tesupp . e   . nbteto . support pour les tetraedres                .
  99 c . teindr . es  . nbteto . valeurs reelles pour les tetraedres        .
 100 c . teindi .  s  . nbteto . valeurs entieres pour les tetraedres       .
 101 c . hesupp . e   . nbheto . support pour les hexaedres                 .
 102 c . heindr . es  . nbheto . valeurs reelles pour les hexaedres         .
 103 c . heindi .  s  . nbheto . valeurs entieres pour les hexaedres        .
 104 c . pysupp . e   . nbpyto . support pour les pyramides                 .
 105 c . pyindr . es  . nbpyto . valeurs reelles pour les pyramides         .
 106 c . pyindi .  s  . nbpyto . valeurs entieres pour les pyramides        .
 107 c . pesupp . e   . nbpeto . support pour les pentaedres                .
 108 c . peindr . es  . nbpeto . valeurs reelles pour les pentaedres        .
 109 c . peindi .  s  . nbpeto . valeurs entieres pour les pentaedres       .
 110 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 111 c . langue . e   .    1   . langue des messages                        .
 112 c .        .     .        . 1 : francais, 2 : anglais                  .
 113 c . codret . es  .    1   . code de retour des modules                 .
 114 c .        .     .        . 0 : pas de probleme                        .
 115 c .        .     .        . 2 : probleme dans le traitement            .
 116 c ______________________________________________________________________
 117 c
 118 c====
 119 c 0. declarations et dimensionnement
 120 c====
 121 c
 122 c 0.1. ==> generalites
 123 c
 124       implicit none
 125       save
 126 c
 127       character*6 nompro
 128       parameter ( nompro = 'DEINRI' )
 129 c
 130 #include "nblang.h"
 131 c
 132 c 0.2. ==> communs
 133 c
 134 #include "envex1.h"
 135 #include "gmreel.h"
 136 c
 137 #include "nombno.h"
 138 #include "nombar.h"
 139 #include "nombtr.h"
 140 #include "nombqu.h"
 141 #include "nombte.h"
 142 #include "nombhe.h"
 143 #include "nombpy.h"
 144 #include "nombpe.h"
 145 c
 146 c 0.3. ==> arguments
 147 c
 148       integer pilraf, pilder
 149       integer typseh, typseb
 150       integer nbsoci
 151       integer usacmp
 152       integer nbvpen, nbvpyr, nbvhex, nbvtet
 153       integer nbvqua, nbvtri, nbvare, nbvnoe
 154 c
 155       integer nosupp(nbnoto), noindi(nbnoto)
 156       integer arsupp(nbarto), arindi(nbarto)
 157       integer trsupp(nbtrto), trindi(nbtrto)
 158       integer qusupp(nbquto), quindi(nbquto)
 159       integer tesupp(nbteto), teindi(nbteto)
 160       integer hesupp(nbheto), heindi(nbheto)
 161       integer pysupp(nbpyto), pyindi(nbpyto)
 162       integer pesupp(nbpeto), peindi(nbpeto)
 163 c
 164       integer ulsort, langue, codret
 165 c
 166       double precision seuilb, seuilh
 167       double precision noindr(nbnoto)
 168       double precision arindr(nbarto)
 169       double precision trindr(nbtrto)
 170       double precision quindr(nbquto)
 171       double precision teindr(nbteto)
 172       double precision heindr(nbheto)
 173       double precision pyindr(nbpyto)
 174       double precision peindr(nbpeto)
 175 c
 176 c 0.4. ==> variables locales
 177 c
 178       integer iaux
 179       integer indtab
 180       integer typenh, typen0
 181       integer ptrav1
 182       integer codre0
 183 c
 184       double precision seuihe, seuibe
 185 c
 186       character*8 ntrav1
 187 c
 188       integer nbmess
 189       parameter (nbmess = 10 )
 190       character*80 texte(nblang,nbmess)
 191 c ______________________________________________________________________
 192 c
 193 c====
 194 c 1. initialisation
 195 c====
 196 c
 197 #include "impr01.h"
 198 c
 199 #ifdef _DEBUG_HOMARD_
 200       write (ulsort,texte(langue,1)) 'Entree', nompro
 201       call dmflsh (iaux)
 202 #endif
 203 c
 204 #include "impr03.h"
 205 c
 206 c====
 207 c 2. allocation de tableaux temporaires
 208 c====
 209 c
 210       iaux = 0
 211       if ( nbvnoe.ne.0 ) then
 212         iaux = iaux + nbnoto
 213       endif
 214       if ( nbvare.ne.0 ) then
 215         iaux = iaux + nbarto
 216       endif
 217       if ( nbvtri.ne.0 ) then
 218         iaux = iaux + nbtrto
 219       endif
 220       if ( nbvqua.ne.0 ) then
 221         iaux = iaux + nbquto
 222       endif
 223       if ( nbvtet.ne.0 ) then
 224         iaux = iaux + nbteto
 225       endif
 226       if ( nbvpyr.ne.0 ) then
 227         iaux = iaux + nbpyto
 228       endif
 229       if ( nbvhex.ne.0 ) then
 230         iaux = iaux + nbheto
 231       endif
 232       if ( nbvpen.ne.0 ) then
 233         iaux = iaux + nbpeto
 234       endif
 235 c
 236       call gmalot ( ntrav1, 'reel    ', iaux, ptrav1, codre0 )
 237 c
 238       codret = max ( abs(codre0), codret )
 239 c
 240 c====
 241 c 3. traitement des indicateurs
 242 c====
 243 #ifdef _DEBUG_HOMARD_
 244       write (ulsort,90002) '3. traitement indicateurs ; codret', codret
 245 #endif
 246 c
 247       indtab = 0
 248       typen0 = -2
 249 c
 250 c 3.1. ==> noeuds
 251 c
 252       if ( nbvnoe.ne.0 ) then
 253 c
 254         if ( codret.eq.0 ) then
 255 c
 256 #ifdef _DEBUG_HOMARD_
 257       write (ulsort,texte(langue,3)) 'DEINTI_no', nompro
 258 #endif
 259         typenh = -1
 260         call deinti ( typenh,
 261      >                usacmp, nbnoto, nosupp, noindr,
 262      >                indtab, rmem(ptrav1),
 263      >                ulsort, langue, codret)
 264         typen0 = typenh
 265 c
 266         endif
 267 c
 268       endif
 269 c
 270 c 3.2. ==> aretes
 271 c
 272       if ( nbvare.ne.0 ) then
 273 c
 274         if ( codret.eq.0 ) then
 275 c
 276 #ifdef _DEBUG_HOMARD_
 277       write (ulsort,texte(langue,3)) 'DEINTI_ar', nompro
 278 #endif
 279         typenh = 1
 280         call deinti ( typenh,
 281      >                usacmp, nbarto, arsupp, arindr,
 282      >                indtab, rmem(ptrav1),
 283      >                ulsort, langue, codret)
 284         if ( typen0.eq.-2 ) then
 285           typen0 = typenh
 286         else
 287           typen0 = 10
 288         endif
 289 c
 290         endif
 291 c
 292       endif
 293 c
 294 c 3.3. ==> triangles
 295 c
 296       if ( nbvtri.ne.0 ) then
 297 c
 298         if ( codret.eq.0 ) then
 299 c
 300 #ifdef _DEBUG_HOMARD_
 301       write (ulsort,texte(langue,3)) 'DEINTI_tr', nompro
 302 #endif
 303         typenh = 2
 304         call deinti ( typenh,
 305      >                usacmp, nbtrto, trsupp, trindr,
 306      >                indtab, rmem(ptrav1),
 307      >                ulsort, langue, codret)
 308         if ( typen0.eq.-2 ) then
 309           typen0 = typenh
 310         else
 311           typen0 = 10
 312         endif
 313 c
 314         endif
 315 c
 316       endif
 317 c
 318 c 3.4. ==> quadrangles
 319 c
 320       if ( nbvqua.ne.0 ) then
 321 c
 322         if ( codret.eq.0 ) then
 323 c
 324 #ifdef _DEBUG_HOMARD_
 325       write (ulsort,texte(langue,3)) 'DEINTI_qu', nompro
 326 #endif
 327         typenh = 4
 328         call deinti ( typenh,
 329      >                usacmp, nbquto, qusupp, quindr,
 330      >                indtab, rmem(ptrav1),
 331      >                ulsort, langue, codret)
 332         if ( typen0.eq.-2 ) then
 333           typen0 = typenh
 334         elseif ( typen0.eq.2 ) then
 335           typen0 = 8
 336         else
 337           typen0 = 10
 338         endif
 339 c
 340         endif
 341 c
 342       endif
 343 c
 344 c 3.5. ==> tetraedres
 345 c
 346       if ( nbvtet.ne.0 ) then
 347 c
 348         if ( codret.eq.0 ) then
 349 c
 350 #ifdef _DEBUG_HOMARD_
 351       write (ulsort,texte(langue,3)) 'DEINTI_te', nompro
 352 #endif
 353         typenh = 3
 354         call deinti ( typenh,
 355      >                usacmp, nbteto, tesupp, teindr,
 356      >                indtab, rmem(ptrav1),
 357      >                ulsort, langue, codret)
 358         if ( typen0.eq.-2 ) then
 359           typen0 = typenh
 360         else
 361           typen0 = 10
 362         endif
 363 c
 364         endif
 365 c
 366       endif
 367 c
 368 c 3.6. ==> pyramides
 369 c
 370       if ( nbvpyr.ne.0 ) then
 371 c
 372         if ( codret.eq.0 ) then
 373 c
 374 #ifdef _DEBUG_HOMARD_
 375       write (ulsort,texte(langue,3)) 'DEINTI_py', nompro
 376 #endif
 377         typenh = 5
 378         call deinti ( typenh,
 379      >                usacmp, nbpyto, pysupp, pyindr,
 380      >                indtab, rmem(ptrav1),
 381      >                ulsort, langue, codret)
 382         if ( typen0.eq.-2 ) then
 383           typen0 = typenh
 384         elseif ( typen0.eq.3 ) then
 385           typen0 = 9
 386         else
 387           typen0 = 10
 388         endif
 389 c
 390         endif
 391 c
 392       endif
 393 c
 394 c 3.7. ==> hexaedres
 395 c
 396       if ( nbvhex.ne.0 ) then
 397 c
 398         if ( codret.eq.0 ) then
 399 c
 400 #ifdef _DEBUG_HOMARD_
 401       write (ulsort,texte(langue,3)) 'DEINTI_he', nompro
 402 #endif
 403         typenh = 6
 404         call deinti ( typenh,
 405      >                usacmp, nbheto, hesupp, heindr,
 406      >                indtab, rmem(ptrav1),
 407      >                ulsort, langue, codret)
 408         if ( typen0.eq.-2 ) then
 409           typen0 = typenh
 410         elseif ( typen0.eq.3 .or. typen0.eq.5 .or. typen0.eq.9 ) then
 411           typen0 = 9
 412         else
 413           typen0 = 10
 414         endif
 415 c
 416         endif
 417 c
 418       endif
 419 c
 420 c 3.8. ==> pentaedres
 421 c
 422       if ( nbvpen.ne.0 ) then
 423 c
 424         if ( codret.eq.0 ) then
 425 c
 426 #ifdef _DEBUG_HOMARD_
 427       write (ulsort,texte(langue,3)) 'DEINTI_pe', nompro
 428 #endif
 429         typenh = 7
 430         call deinti ( typenh,
 431      >                usacmp, nbpeto, pesupp, peindr,
 432      >                indtab, rmem(ptrav1),
 433      >                ulsort, langue, codret)
 434         if ( typen0.eq.-2 ) then
 435           typen0 = typenh
 436         elseif ( typen0.eq.3 .or. typen0.eq.5 .or.
 437      >           typen0.eq.6 .or. typen0.eq.9 ) then
 438           typen0 = 9
 439         else
 440           typen0 = 10
 441         endif
 442 c
 443         endif
 444 c
 445       endif
 446 c
 447 c====
 448 c 4. determination du seuil
 449 c====
 450 #ifdef _DEBUG_HOMARD_
 451       write (ulsort,90002) '4. determination du seuil ; codret', codret
 452 #endif
 453 cgn      call gmprsx (nompro, ntrav1 )
 454 c
 455       if ( codret.eq.0 ) then
 456 c
 457 #ifdef _DEBUG_HOMARD_
 458       write (ulsort,texte(langue,3)) 'DEINSE', nompro
 459 #endif
 460 c
 461       call deinse ( typen0,
 462      >              seuihe, seuibe,
 463      >              pilraf, pilder,
 464      >              typseh, typseb, seuilh, seuilb, nbsoci,
 465      >              indtab, rmem(ptrav1),
 466      >              ulsort, langue, codret)
 467 c
 468       endif
 469 c
 470 c====
 471 c 5. transfert de reel a entier
 472 c====
 473 #ifdef _DEBUG_HOMARD_
 474       write (ulsort,90002) '5. transfert reel/entier ; codret', codret
 475 #endif
 476 c 5.1. ==> noeuds
 477 c
 478       if ( nbvnoe.ne.0 ) then
 479 c
 480         if ( codret.eq.0 ) then
 481 c
 482 #ifdef _DEBUG_HOMARD_
 483       write (ulsort,texte(langue,3)) 'DEINST_no', nompro
 484 #endif
 485         typenh = -1
 486         call deinst ( typenh,
 487      >                seuihe, seuibe,
 488      >                nbnoto, nosupp, noindr, noindi,
 489      >                ulsort, langue, codret)
 490 c
 491         endif
 492 c
 493       endif
 494 c
 495 c 5.2. ==> aretes
 496 c
 497       if ( nbvare.ne.0 ) then
 498 c
 499         if ( codret.eq.0 ) then
 500 c
 501 #ifdef _DEBUG_HOMARD_
 502       write (ulsort,texte(langue,3)) 'DEINST_ar', nompro
 503 #endif
 504         typenh = 1
 505         call deinst ( typenh,
 506      >                seuihe, seuibe,
 507      >                nbarto, arsupp, arindr, arindi,
 508      >                ulsort, langue, codret)
 509 c
 510         endif
 511 c
 512       endif
 513 c
 514 c 5.3. ==> triangles
 515 c
 516       if ( nbvtri.ne.0 ) then
 517 c
 518         if ( codret.eq.0 ) then
 519 c
 520 #ifdef _DEBUG_HOMARD_
 521       write (ulsort,texte(langue,3)) 'DEINST_tr', nompro
 522 #endif
 523         typenh = 2
 524         call deinst ( typenh,
 525      >                seuihe, seuibe,
 526      >                nbtrto, trsupp, trindr, trindi,
 527      >                ulsort, langue, codret)
 528 c
 529         endif
 530 c
 531       endif
 532 c
 533 c 5.4. ==> quadrangles
 534 c
 535       if ( nbvqua.ne.0 ) then
 536 c
 537         if ( codret.eq.0 ) then
 538 c
 539 #ifdef _DEBUG_HOMARD_
 540       write (ulsort,texte(langue,3)) 'DEINST_qu', nompro
 541 #endif
 542         typenh = 4
 543         call deinst ( typenh,
 544      >                seuihe, seuibe,
 545      >                nbquto, qusupp, quindr, quindi,
 546      >                ulsort, langue, codret)
 547 c
 548         endif
 549 c
 550       endif
 551 c
 552 c 5.5. ==> tetraedres
 553 c
 554       if ( nbvtet.ne.0 ) then
 555 c
 556         if ( codret.eq.0 ) then
 557 c
 558 #ifdef _DEBUG_HOMARD_
 559       write (ulsort,texte(langue,3)) 'DEINST_te', nompro
 560 #endif
 561         typenh = 3
 562         call deinst ( typenh,
 563      >                seuihe, seuibe,
 564      >                nbteto, tesupp, teindr, teindi,
 565      >                ulsort, langue, codret)
 566 c
 567         endif
 568 c
 569       endif
 570 c
 571 c 5.6. ==> pyramides
 572 c
 573       if ( nbvpyr.ne.0 ) then
 574 c
 575         if ( codret.eq.0 ) then
 576 c
 577 #ifdef _DEBUG_HOMARD_
 578       write (ulsort,texte(langue,3)) 'DEINST_py', nompro
 579 #endif
 580         typenh = 5
 581         call deinst ( typenh,
 582      >                seuihe, seuibe,
 583      >                nbpyto, pysupp, pyindr, pyindi,
 584      >                ulsort, langue, codret)
 585 c
 586         endif
 587 c
 588       endif
 589 c
 590 c 5.7. ==> hexaedres
 591 c
 592       if ( nbvhex.ne.0 ) then
 593 c
 594         if ( codret.eq.0 ) then
 595 c
 596 #ifdef _DEBUG_HOMARD_
 597       write (ulsort,texte(langue,3)) 'DEINST_he', nompro
 598 #endif
 599         typenh = 6
 600         call deinst ( typenh,
 601      >                seuihe, seuibe,
 602      >                nbheto, hesupp, heindr, heindi,
 603      >                ulsort, langue, codret)
 604 c
 605         endif
 606 c
 607       endif
 608 c
 609 c 5.8. ==> pentaedres
 610 c
 611       if ( nbvpen.ne.0 ) then
 612 c
 613         if ( codret.eq.0 ) then
 614 c
 615 #ifdef _DEBUG_HOMARD_
 616       write (ulsort,texte(langue,3)) 'DEINST_pe', nompro
 617 #endif
 618         typenh = 7
 619         call deinst ( typenh,
 620      >                seuihe, seuibe,
 621      >                nbpeto, pesupp, peindr, peindi,
 622      >                ulsort, langue, codret)
 623 c
 624         endif
 625 c
 626       endif
 627 c
 628 c====
 629 c 6. liberation des tableaux temporaires
 630 c====
 631 #ifdef _DEBUG_HOMARD_
 632       write (ulsort,90002) '6. liberation ; codret', codret
 633 #endif
 634 c
 635       if ( codret.eq.0 ) then
 636 c
 637       call gmlboj ( ntrav1 , codre0 )
 638 c
 639       codret = max ( abs(codre0), codret )
 640 c
 641       endif
 642 c
 643       seuilh = seuihe
 644 c====
 645 c 7. la fin
 646 c====
 647 c
 648       if ( codret.ne.0 ) then
 649 c
 650 #include "envex2.h"
 651 c
 652       write (ulsort,texte(langue,1)) 'Sortie', nompro
 653       write (ulsort,texte(langue,2)) codret
 654 c
 655       endif
 656 c
 657 #ifdef _DEBUG_HOMARD_
 658       write (ulsort,texte(langue,1)) 'Sortie', nompro
 659       call dmflsh (iaux)
 660 #endif
 661 c
 662       end