src/tool/Decision/decine.F

   1       subroutine decine ( nupaci, nbsoci, nbsoav,
   2      >                    seuilh, seuinf, seusup,
   3      >                    nomail,
   4      >                    indnoe, indnp2, indnim, indare,
   5      >                    indtri, indqua,
   6      >                    indtet, indhex, indpen,
   7      >                    lgopts, taopts, lgetco, taetco,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    DEcision - CIble - Noeud ou Elements
  30 c    --         --      -        -
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . nupaci . es  .   1    . numero du passage en cours pour la         .
  36 c .        .     .        . recherche de cible                         .
  37 c .        .     .        . vaut -1 si la cible est atteinte           .
  38 c . nbsoci . e   .   1    . cible en nombre de sommets  (-1 si non)    .
  39 c . nbmaci . e   .   1    . cible en nombre de mailles (-1 si non)     .
  40 c . nbsoav . es  .   1    . nombre de sommetes aux etapes anterieures  .
  41 c . seuilh . es  .   1    . borne superieure de l'erreur (absolue)     .
  42 c . seuinf . es  .   1    . meilleur seuil inferieur en nombre noeuds  .
  43 c . seusup . es  .   1    . meilleur seuil superieur en nombre noeuds  .
  44 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  45 c . indnoe . es  .   1    . indice du dernier noeud cree               .
  46 c . indnp2 . es  .   1    . nombre de noeuds p2 en vigueur             .
  47 c . indnim . es  .   1    . nombre de noeuds internes en vigueur       .
  48 c . indare . es  .   1    . indice de la derniere arete creee          .
  49 c . indtri . es  .   1    . indice du dernier triangle cree            .
  50 c . indqua . es  .   1    . indice du dernier quadrangle cree          .
  51 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  52 c . indhex . es  .   1    . indice du dernier hexaedre cree            .
  53 c . indpen . es  .   1    . indice du dernier pentaedre cree           .
  54 c . lgopts . e   .   1    . longueur du tableau des options caracteres .
  55 c . taopts . e   . lgopts . tableau des options caracteres             .
  56 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  57 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  58 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  59 c . langue . e   .   1    . langue des messages                        .
  60 c .        .     .        . 1 : francais, 2 : anglais                  .
  61 c . codret . e/s .   1    . code de retour des modules                 .
  62 c .        .     .        . 0 : pas de probleme                        .
  63 c ______________________________________________________________________
  64 c
  65 c====
  66 c 0. declarations et dimensionnement
  67 c====
  68 c
  69 c 0.1. ==> generalites
  70 c
  71       implicit none
  72       save
  73 c
  74       character*6 nompro
  75       parameter ( nompro = 'DECINE' )
  76 c
  77 #include "nblang.h"
  78 c
  79 c 0.2. ==> communs
  80 c
  81 #include "envex1.h"
  82 #include "envca1.h"
  83 c
  84 #include "nombno.h"
  85 #include "nouvnb.h"
  86 c
  87 c 0.3. ==> arguments
  88 c
  89       integer nupaci, nbsoci
  90       integer nbsoav(6)
  91 c
  92       character*8 nomail
  93 c
  94       integer indnoe, indnp2, indnim, indare, indtri, indqua
  95       integer indtet, indhex, indpen
  96 c
  97       double precision seuilh, seuinf, seusup
  98 c
  99       integer lgopts
 100       character*8 taopts(lgopts)
 101 c
 102       integer lgetco
 103       integer taetco(lgetco)
 104 c
 105       integer ulsort, langue, codret
 106 c
 107 c 0.4. ==> variables locales
 108 c
 109       integer codava
 110       integer nretap, nrsset
 111       integer iaux, jaux
 112 c
 113       integer nbsoan, nbsono
 114       integer nbnoan, nbnono
 115       integer nbaran, nbarno
 116       integer nbtran, nbtrno
 117       integer nbquan, nbquno
 118       integer nbtean, nbteno
 119       integer nbhean, nbheno
 120       integer nbpean, nbpeno
 121       integer nbpyan, nbpyno
 122 c
 123       double precision daux
 124 c
 125       character*6 saux
 126       character*8 norenu
 127       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 128       character*8 nhtetr, nhhexa, nhpyra, nhpent
 129       character*8 nhelig
 130       character*8 nhvois, nhsupe, nhsups
 131       character*8 ndecar, ndecfa
 132 c
 133       integer nbmess
 134       parameter ( nbmess = 11 )
 135       character*80 texte(nblang,nbmess)
 136 c
 137 c 0.5. ==> initialisations
 138 c ______________________________________________________________________
 139 c
 140 c====
 141 c 1. messages
 142 c====
 143 c
 144       codava = codret
 145 c
 146 c=======================================================================
 147       if ( codava.eq.0 ) then
 148 c=======================================================================
 149 c
 150 c 1.3. ==> les messages
 151 c
 152 #include "impr01.h"
 153 c
 154 #ifdef _DEBUG_HOMARD_
 155       write (ulsort,texte(langue,1)) 'Entree', nompro
 156       call dmflsh (iaux)
 157 #endif
 158 c
 159 #ifdef _DEBUG_HOMARD_
 160       write (ulsort,90002) 'nupaci', nupaci
 161 #endif
 162 c
 163       texte(1,4) = '(/,a6,'' DECOMPTE DES NOUVELLES ENTITES'')'
 164       texte(1,5) = '(37(''=''),/)'
 165       texte(1,6) = '(''Pas assez de raffinement '',a)'
 166       texte(1,7) = '(''Trop de raffinement '',a)'
 167       texte(1,8) = '(''La cible est atteinte.'')'
 168       texte(1,9) = '(''Le nombre de noeuds ne bouge plus.'')'
 169       texte(1,10) = '(''Le nombre de noeuds alterne.'')'
 170       texte(1,11) = '(''Arret du processus.'')'
 171 c
 172       texte(2,4) = '(/,a6,'' COUNTING OF NEW ENTITIES'')'
 173       texte(2,5) = '(31(''=''),/)'
 174       texte(2,6) = '(''Not enough refinement '',a)'
 175       texte(2,7) = '(''Too many refinement '',a)'
 176       texte(2,8) = '(''The target is reached.'')'
 177       texte(2,9) = '(''No more evolution of the number of nodes.'')'
 178       texte(2,10) = '(''The number of nodes alternates.'')'
 179       texte(2,11) = '(''The process is over.'')'
 180 c
 181 #include "impr03.h"
 182 c
 183 c 1.4. ==> le numero de sous-etape
 184 c
 185       nretap = taetco(1)
 186       nrsset = taetco(2) + 1
 187       taetco(2) = nrsset
 188 c
 189       call utcvne ( nretap, nrsset, saux, iaux, codret )
 190 c
 191 c 1.5. ==> le titre
 192 c
 193       write (ulsort,texte(langue,4)) saux
 194       write (ulsort,texte(langue,5))
 195 c
 196 c====
 197 c 2. recuperation des pointeurs
 198 c====
 199 c
 200       if ( codret.eq.0 ) then
 201 c
 202 #ifdef _DEBUG_HOMARD_
 203       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 204 #endif
 205 c
 206       call utnomh ( nomail,
 207      >                sdim,   mdim,
 208      >               degre, maconf, homolo, hierar,
 209      >              rafdef, nbmane, typcca, typsfr, maextr,
 210      >              mailet,
 211      >              norenu,
 212      >              nhnoeu, nhmapo, nharet,
 213      >              nhtria, nhquad,
 214      >              nhtetr, nhhexa, nhpyra, nhpent,
 215      >              nhelig,
 216      >              nhvois, nhsupe, nhsups,
 217      >              ulsort, langue, codret)
 218 c
 219       endif
 220 c
 221 c====
 222 c 3. programmes generiques
 223 c====
 224 #ifdef _DEBUG_HOMARD_
 225       write (ulsort,90002) '3. programmes generiques ; codret', codret
 226 #endif
 227 c
 228 c 3.1. ==> Base
 229 c
 230       if ( codret.eq.0 ) then
 231 c
 232       ndecar = taopts(11)
 233       ndecfa = taopts(12)
 234 c
 235       endif
 236 c
 237 c 3.2. ==> Nombre de valeurs
 238 c
 239       if ( codret.eq.0 ) then
 240 c
 241       iaux = 0
 242 #ifdef _DEBUG_HOMARD_
 243       jaux = 1
 244 #else
 245       jaux = 0
 246 #endif
 247 c
 248 #ifdef _DEBUG_HOMARD_
 249       write (ulsort,texte(langue,3)) 'UTAL00', nompro
 250 #endif
 251       call utal00 (   iaux,   jaux,
 252      >              nomail, ndecar, ndecfa,
 253      >              indnoe, indnp2, indnim, indare,
 254      >              indtri, indqua,
 255      >              indtet, indhex, indpen,
 256      >              nbsoan, nbsono,
 257      >              nbnoan, nbnono,
 258      >              nbaran, nbarno,
 259      >              nbtran, nbtrno,
 260      >              nbquan, nbquno,
 261      >              nbtean, nbteno,
 262      >              nbhean, nbheno,
 263      >              nbpean, nbpeno,
 264      >              nbpyan, nbpyno,
 265      >              ulsort, langue, codret )
 266 c
 267       endif
 268 c
 269 c====
 270 c 4. Evaluation
 271 c====
 272 #ifdef _DEBUG_HOMARD_
 273       write (ulsort,90002) '3. programmes generiques ; codret', codret
 274 #endif
 275 c
 276       if ( codret.eq.0 ) then
 277 c
 278 #ifdef _DEBUG_HOMARD_
 279       write (ulsort,90004) 'seuilh', seuilh
 280       write (ulsort,90004) 'seuinf avant', seuinf
 281       write (ulsort,90004) 'seusup avant', seusup
 282       write (ulsort,90002) 'nbsoav avant', nbsoav
 283       write (ulsort,90002) 'nbnop1', nbnop1
 284       write (ulsort,90002) 'nbsono', nbsono
 285       write (ulsort,90002) 'nbsoci', nbsoci
 286 #endif
 287 c
 288 c 4.1. ==> Miracle ! La cible est atteinte : on arrete
 289 c
 290       if ( nbsono.eq.nbsoci ) then
 291 c
 292 #ifdef _DEBUG_HOMARD_
 293         write (ulsort,texte(langue,8))
 294 #endif
 295 c
 296         nupaci = -1
 297 c
 298       endif
 299 c
 300 c 4.2. ==> La cible n'est pas atteinte au premier passage :
 301 c          on applique un pourcentage de 20%
 302 c
 303       if ( nupaci.eq.1 ) then
 304 c
 305 c 4.2.1. ==> Pas assez de raffinement
 306 c
 307         if ( nbsono.lt.nbsoci ) then
 308 #ifdef _DEBUG_HOMARD_
 309           write (ulsort,texte(langue,6)) ' '
 310 #endif
 311           if ( seuilh.gt.0.d0 ) then
 312             daux = 0.8d0
 313           else
 314             daux = 1.2d0
 315           endif
 316           seuinf = seuilh
 317 c
 318 c 4.2.2. ==> Trop de raffinement
 319 c
 320         else
 321 #ifdef _DEBUG_HOMARD_
 322           write (ulsort,texte(langue,7)) ' '
 323 #endif
 324           if ( seuilh.gt.0.d0 ) then
 325             daux = 1.2d0
 326           else
 327             daux = 0.8d0
 328           endif
 329           seusup = seuilh
 330         endif
 331 c
 332 c 4.2.3. ==> Nouveau seuil
 333 c
 334         seuilh = seuilh*daux
 335 c
 336       endif
 337 c
 338 c 4.3. ==> Arret eventuel aux passages suivants
 339 c          Si on alterne, on arrete au meilleur choix
 340 c
 341       if ( nupaci.gt.1 ) then
 342 c
 343         if ( nbsono.eq.nbsoav(2) .and.
 344      >       nbsono.eq.nbsoav(4) .and.
 345      >       nbsono.eq.nbsoav(6) .and.
 346      >       nbsoav(1).eq.nbsoav(3) .and.
 347      >       nbsoav(3).eq.nbsoav(5) ) then
 348 c
 349           iaux = abs(nbsono-nbsoci)
 350           jaux = abs(nbsoav(1)-nbsoci)
 351 #ifdef _DEBUG_HOMARD_
 352           write (ulsort,90002) 'nbsono-nbsoci', iaux
 353           write (ulsort,90002) 'nbsoav(1)-nbsoci', jaux
 354 #endif
 355           if ( iaux.le.jaux ) then
 356 #ifdef _DEBUG_HOMARD_
 357             write (ulsort,texte(langue,10))
 358 #endif
 359             nupaci = -1
 360           endif
 361 c
 362         endif
 363 c
 364       endif
 365 c
 366 c 4.4. ==> Poursuite aux passages suivants
 367 c          On decale de la meme quantite quand on progresse dans
 368 c          le meme sens, sinon dichotomie
 369 c
 370       if ( nupaci.gt.1 ) then
 371 c
 372 c 4.4.1. ==> Si pas assez de raffinement
 373 c
 374         if ( nbsono.lt.nbsoci ) then
 375 #ifdef _DEBUG_HOMARD_
 376           write (ulsort,texte(langue,6)) ' '
 377 #endif
 378 c           Pas assez de raffinement au passage precedent
 379           if ( nbsoav(1).lt.nbsoci ) then
 380 #ifdef _DEBUG_HOMARD_
 381             write (ulsort,texte(langue,6)) 'avant'
 382 #endif
 383             daux = seuilh - seuinf
 384             seuinf = seuilh
 385             seuilh = min(seusup, seuilh+daux)
 386           else
 387             seuinf = seuilh
 388 #ifdef _DEBUG_HOMARD_
 389             write (ulsort,texte(langue,7)) 'avant'
 390 #endif
 391             seuilh = 0.5d0*(seusup+seuilh)
 392           endif
 393 c
 394 c 4.4.2. ==> Si trop de raffinement
 395 c
 396         else
 397 #ifdef _DEBUG_HOMARD_
 398           write (ulsort,texte(langue,7)) ' '
 399 #endif
 400 c           Pas assez de raffinement au passage precedent
 401           if ( nbsoav(1).lt.nbsoci ) then
 402 #ifdef _DEBUG_HOMARD_
 403             write (ulsort,texte(langue,6)) 'avant'
 404 #endif
 405             seusup = seuilh
 406             seuilh = 0.5d0*(seuilh+seuinf)
 407           else
 408 #ifdef _DEBUG_HOMARD_
 409             write (ulsort,texte(langue,7)) 'avant'
 410 #endif
 411             daux = seuilh - seusup
 412             seusup = seuilh
 413             seuilh = max(seuinf, seuilh+daux)
 414           endif
 415 c
 416         endif
 417 c
 418       endif
 419 c
 420 c 4.5. ==> Preparation de l'etape suivante
 421 c
 422       if ( nupaci.ge.1 ) then
 423 c
 424         do 45 , iaux = 6, 2, -1
 425           nbsoav(iaux) = nbsoav(iaux-1)
 426    45   continue
 427         nbsoav(1) = nbsono
 428 c
 429 #ifdef _DEBUG_HOMARD_
 430         write (ulsort,90002) 'nbsoav apres', nbsoav
 431         write (ulsort,90004) 'seuilh apres', seuilh
 432         write (ulsort,90004) 'seuinf apres', seuinf
 433         write (ulsort,90004) 'seusup apres', seusup
 434 #endif
 435 c
 436         nupaci = nupaci + 1
 437 c
 438       endif
 439 c
 440 #ifdef _DEBUG_HOMARD_
 441       write (ulsort,90002) 'nupaci', nupaci
 442 #endif
 443 c
 444 #ifdef _DEBUG_HOMARD_
 445       if ( nupaci.lt.0 ) then
 446         write (ulsort,texte(langue,11))
 447       endif
 448 #endif
 449 c
 450       endif
 451 c
 452 c====
 453 c 5. la fin
 454 c====
 455 c
 456       if ( codret.ne.0 ) then
 457 c
 458 #include "envex2.h"
 459 c
 460       write (ulsort,texte(langue,1)) 'Sortie', nompro
 461       write (ulsort,texte(langue,2)) codret
 462 c
 463       endif
 464 c
 465 #ifdef _DEBUG_HOMARD_
 466       write (ulsort,texte(langue,1)) 'Sortie', nompro
 467       call dmflsh (iaux)
 468 #endif
 469 c
 470 c=======================================================================
 471       endif
 472 c=======================================================================
 473 c
 474       end