src/tool/Decision/desmaj.F

   1       subroutine desmaj ( nhnoeu, nharet, nhtria, nhquad,
   2      >                    nhtetr, nhhexa, nhpyra, nhpent,
   3      >                    afaire,
   4      >                    ulsort, langue, codret)
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c traitement des DEcisions - Suppression - Mise A Jour
  26 c                --          -             -    - -
  27 c ______________________________________________________________________
  28 c
  29 c but : mises a jour des communs apres suppression des entites de mise
  30 c       en conformite
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . nhnoeu . e   . char8  . nom de l'objet decrivant les noeuds        .
  36 c . nharet . e   . char8  . nom de l'objet decrivant les aretes        .
  37 c . nhtria . e   . char8  . nom de l'objet decrivant les triangles     .
  38 c . nhquad . e   . char8  . nom de l'objet decrivant les quadrangles   .
  39 c . nhtetr . e   . char8  . nom de l'objet decrivant les hexaedres     .
  40 c . nhhexa . e   . char8  . nom de l'objet decrivant les tetraedres    .
  41 c . nhpyra . e   . char8  . nom de l'objet decrivant les pyramides     .
  42 c . nhpent . e   . char8  . nom de l'objet decrivant les pentaedres    .
  43 c . afaire .  s  . logic  . vrai, si la numerotation des noeuds doit   .
  44 c .        .     .        . etre revue                                 .
  45 c .        .     .        . faux, si un raccourcissement suffit        .
  46 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  47 c . langue . e   .    1   . langue des messages                        .
  48 c .        .     .        . 1 : francais, 2 : anglais                  .
  49 c . codret . es  .    1   . code de retour des modules                 .
  50 c .        .     .        . 0 : pas de probleme                        .
  51 c .        .     .        . 1 : probleme                               .
  52 c ______________________________________________________________________
  53 c
  54 c====
  55 c 0. declarations et dimensionnement
  56 c====
  57 c
  58 c 0.1. ==> generalites
  59 c
  60       implicit none
  61       save
  62 c
  63       character*6 nompro
  64       parameter ( nompro = 'DESMAJ' )
  65 c
  66 #include "nblang.h"
  67 c
  68 c 0.2. ==> communs
  69 c
  70 #include "envex1.h"
  71 c
  72 #include "envca1.h"
  73 #include "nombno.h"
  74 #include "nombar.h"
  75 #include "nombtr.h"
  76 #include "nombqu.h"
  77 #include "nombte.h"
  78 #include "nombhe.h"
  79 #include "nombpy.h"
  80 #include "nombpe.h"
  81 #include "impr02.h"
  82 c
  83 c 0.3. ==> arguments
  84 c
  85       character*8 nhnoeu, nharet, nhtria, nhquad
  86       character*8 nhtetr, nhhexa, nhpyra, nhpent
  87 c
  88       logical afaire
  89 c
  90       integer ulsort, langue, codret
  91 c
  92 c 0.4. ==> variables locales
  93 c
  94       integer iaux
  95       integer codre1, codre2, codre3, codre4, codre5
  96       integer codre6, codre7, codre8
  97       integer codre0
  98 c
  99       integer nbmess
 100       parameter ( nbmess = 10 )
 101       character*80 texte(nblang,nbmess)
 102 c
 103 c 0.5. ==> initialisations
 104 c ______________________________________________________________________
 105 c
 106 c====
 107 c 1. messages
 108 c====
 109 c
 110 #include "impr01.h"
 111 c
 112 #ifdef _DEBUG_HOMARD_
 113       write (ulsort,texte(langue,1)) 'Entree', nompro
 114       call dmflsh (iaux)
 115 #endif
 116 c
 117       texte(1,4) = '(5x,''Nombre de '',a,''        : '',i10)'
 118       texte(1,5) = '(5x,''Nombre de '',a,'' actifs : '',i10)'
 119 c
 120       texte(2,4) = '(5x,''Number of '',a,''        : '',i10)'
 121       texte(2,5) = '(5x,''Number of active '',a,'' : '',i10)'
 122 c
 123 #include "impr03.h"
 124 c
 125 c====
 126 c 2. mise a jour des nombres d'entites du maillage
 127 c====
 128 c    remarques :
 129 c  - lorsqu'on supprime des entites provisoires, leur mere reapparait.
 130 c  - les nombres de paires d'homologues ne seront mis a jour qu'apres
 131 c    raffinement du maillage. il faut veiller a ne pas utiliser les
 132 c    tables ho1noe ... avant cela.
 133 c
 134 c 2.1. commun "nombno" --> noeuds
 135 c     remarque : voir utplco pour la coherence des chiffres
 136 c     Les noeuds a supprimer sont ceux qui sont :
 137 c      - au centre des quadrangles coupes selon 2 aretes adjacentes.
 138 c      - au centre des hexaedres coupes selon 2 ou 3 aretes.
 139 c      - au centre des pentaedres coupes selon 2 aretes de triangles
 140 c        ou 1 face triangulaire.
 141 c     . En degre 1 :
 142 c     Par construction, ces noeuds sont numerotes en dernier. Il suffit
 143 c     donc de raccourcir les tableaux des noeuds du nombre de
 144 c     quadrangles, d'hexaedres ou de pentaedres concernes.
 145 c     . En degre 2, les aretes de mise en conformite disparaissant, les
 146 c     noeuds P2 qu'elles portent doivent disparaitre. Par creation, ils
 147 c     sont numerotes en dernier.
 148 c      De plus, si on a supprime un noeud central, ce noeud a ete cree
 149 c      avant les nouveaux noeuds P2, Il faut donc remanier la
 150 c      numerotation des noeuds.
 151 c
 152 c     nbnois = non modifie
 153 c     nbnoei = non modifie
 154 c     nbpnho = mis a jour dans cmhomo/uthonh - non utilise avant
 155 c     nbnoma = non modifie
 156 c     nbnop1 = non modifie
 157 c
 158 #ifdef _DEBUG_HOMARD_
 159       write (ulsort,90002) 'mailet', mailet
 160       write (ulsort,90002) 'nbnoin', nbnoin
 161       write (ulsort,*) ' '
 162       write (ulsort,90002) 'nbart2', nbart2
 163       write (ulsort,90002) 'nbarq2', nbarq2
 164       write (ulsort,90002) 'nbarq3', nbarq3
 165       write (ulsort,90002) 'nbarq5', nbarq5
 166       write (ulsort,90002) 'nbarin', nbarin
 167       write (ulsort,*) ' '
 168       write (ulsort,90002) 'nbtrt2', nbtrt2
 169       write (ulsort,90002) 'nbtrq3', nbtrq3
 170       write (ulsort,*) ' '
 171       write (ulsort,90002) 'nbquq2', nbquq2
 172       write (ulsort,90002) 'nbquq5', nbquq5
 173       write (ulsort,*) ' '
 174       write (ulsort,90002) 'nbteh2', nbteh2
 175       write (ulsort,90002) 'nbteh3', nbteh3
 176       write (ulsort,90002) 'nbtedh', nbtedh
 177       write (ulsort,90002) 'nbtep3', nbtep3
 178       write (ulsort,90002) 'nbtep5', nbtep5
 179       write (ulsort,90002) 'nbtedp', nbtedp
 180       write (ulsort,90002) 'debut de '//nompro//' nbnoto', nbnoto
 181       write (ulsort,90002) 'debut de '//nompro//' nbnop2', nbnop2
 182       write (ulsort,90002) 'debut de '//nompro//' nbnoim', nbnoim
 183 #endif
 184       afaire = .false.
 185       iaux = nbquq5/3
 186      >     + nbnoin
 187 #ifdef _DEBUG_HOMARD_
 188       write (ulsort,90002) 'nombre de noeuds P1 a supprimer', iaux
 189 #endif
 190       nbnoto = nbnoto - iaux
 191       if ( degre.eq.2 ) then
 192         iaux = nbart2
 193      >       + nbarq2 + nbarq3 + nbarq5
 194      >       + nbarin
 195 #ifdef _DEBUG_HOMARD_
 196         write (ulsort,90002) 'nombre de noeuds P2 a supprimer', iaux
 197 #endif
 198         nbnoto = nbnoto - iaux
 199         nbnop2 = nbnop2 - iaux
 200         if ( nbquq5.ne.0 .or. nbnoin.ne.0 ) then
 201           afaire = .true.
 202         endif
 203       endif
 204 c
 205       if ( mod(mailet,2).eq.0 ) then
 206 c
 207         nbnoto = nbnoto - nbtrt2
 208         nbnoim = nbnoim - nbtrt2
 209 c
 210       endif
 211 c
 212       if ( mod(mailet,3).eq.0 ) then
 213 c
 214         nbnoto = nbnoto - nbtrq3
 215         nbnoim = nbnoim - nbtrq3
 216 c
 217       endif
 218 c
 219       if ( mod(mailet,5).eq.0 ) then
 220 c
 221         codret = 31
 222 c
 223       endif
 224 c
 225       nbnoin = 0
 226 c
 227 cgn      write (ulsort,90002) '==> nouveau nbnoto', nbnoto
 228 cgn      write (ulsort,90002) '==> nouveau nbnop2', nbnop2
 229 cgn      write (ulsort,90002) '==> nouveau nbnoim', nbnoim
 230 cgn      write (ulsort,99001) '==> afaire', afaire
 231
 232 c 2.2. commun "nombar" --> aretes
 233 c
 234 cgn      write(*,*) nbart2, nbarq3, nbarin
 235       iaux = nbart2
 236      >     + nbarq2 + nbarq3 + nbarq5 + nbarin
 237 cgn      write (ulsort,90002) 'nombre d''aretes a supprimer', iaux
 238       nbarac = nbarac - iaux
 239 c     nbarde = non modifie
 240       nbart2 = 0
 241       nbarq2 = 0
 242       nbarq3 = 0
 243       nbarq5 = 0
 244       nbarin = 0
 245 c     nbarma = non modifie
 246 c     nbarpe = non modifie
 247       nbarto = nbarpe
 248 c     nbfaar = modifie plus tard par utfaa1
 249 c     nbpaho = mis a jour dans cmhomo/uthonh - non utilise avant
 250 c
 251 c 2.3. commun "nombqu" --> quadrangles
 252 c      remarque : a faire avant les triangles, sinon les nombres
 253 c                 sont faux
 254 c     . un triplet de triangles issus d'un decoupage en 3 d'un
 255 c       quadrangle reactive 1 quadrangle et 0 triangle : nombre de
 256 c       triangles actifs = -3, nombre de quadrangles actifs = +1
 257 c     . un doublet de quadrangles issus d'un decoupage en 2 d'un
 258 c       quadrangle reactive 1 quadrangle et en detruit 2 = -1
 259 c     . un triplet de quadrangles issus d'un decoupage en 3 d'un
 260 c       quadrangle reactive 1 quadrangle et en detruit 3 = -2/3
 261 c
 262       iaux = nbtrq3/3 - nbquq2 - 2*nbquq5/3
 263 cgn      write (ulsort,90002) 'bilan sur les quadrangles', iaux
 264       nbquac = nbquac + iaux
 265 c     nbqude = non modifie
 266       nbquq2 = 0
 267       nbquq5 = 0
 268 c     nbquma = non modifie
 269 c     nbqupe = non modifie
 270       nbquto = nbqupe
 271 c     nbpqho = mis a jour dans cmhomo/uthonh - non utilise avant
 272 c
 273 c 2.4. commun "nombtr" --> triangles
 274 c     . une paire de triangles issus d'un decoupage en 2 d'un triangle
 275 c       reactive 1 triangle : nombre de triangles actifs = -2 +1
 276 c     . un triplet de triangles issus d'un decoupage en 3 d'un
 277 c       quadrangle reactive 1 quadrangle et 0 triangle : nombre de
 278 c       triangles actifs = -3, nombre de quadrangles actifs = +1
 279 c     . un ensemble de triangles issus d'un decoupage interne a un
 280 c       volume ne reactive aucun triangle : nombre de triangles
 281 c       actifs = -n
 282 c
 283       iaux = nbtrt2/2 + nbtrq3 + nbtrhc + nbtrpc + nbtrtc
 284 cgn      write (ulsort,90002) 'nombre de triangles a supprimer', iaux
 285       nbtrac = nbtrac - iaux
 286 c     nbtrde = non modifie
 287       nbtrt2 = 0
 288       nbtrq3 = 0
 289       nbtrhc = 0
 290       nbtrpc = 0
 291       nbtrtc = 0
 292 c     nbtrma = non modifie
 293 c     nbtrpe = non modifie
 294       nbtrto = nbtrpe
 295 c     nbptho = mis a jour dans cmhomo/uthonh - non utilise avant
 296 c
 297 c 2.5. commun "nombhe" --> hexaedres
 298 c     . chaque suppression de conformite des hexaedres supprime tous
 299 c       les hexaedres concernes et reactive les peres
 300 c
 301       iaux = nbhedh - nbheco
 302 c
 303       nbheac = nbheac - iaux
 304       nbheco = 0
 305       nbhedh = 0
 306 c     nbhede = non modifie
 307 c     nbhema = non modifie
 308 c     nbhepe = non modifie
 309       nbheto = nbhepe
 310       nbhecf = nbheto
 311       nbheca = 0
 312 c
 313 c 2.6. commun "nombte" --> tetraedres
 314 c     . une paire de tetraedres issus d'un decoupage en 2 d'un tetraedre
 315 c       reactive 1 tetraedre : nombre de tetraedres actifs = -2 +1
 316 c     . un quadruplet de tetraedres issus d'un decoupage en 4 d'un
 317 c       tetraedre reactive 1 tetraedre : nombre de tetraedres
 318 c       actifs = -4 +1
 319 c     . chaque suppression de conformite des hexaedres supprime tous
 320 c       les tetraedres concernes
 321 c     . chaque suppression de conformite des pentaedres supprime tous
 322 c       les tetraedres concernes
 323 c
 324       iaux = nbtea2/2 + 3*(nbtea4 + nbtef4)/4
 325      >     + nbteh1 + nbteh2 + nbteh3 + nbteh4
 326      >     + nbtep0 + nbtep1 + nbtep2 + nbtep3 + nbtep4 + nbtep5
 327      >     + nbtedh + nbtedp
 328 cgn      write (ulsort,90002) 'nombre de tetraedres a supprimer', iaux
 329       nbteac = nbteac - iaux
 330       nbtea2 = 0
 331       nbtea4 = 0
 332       nbtef4 = 0
 333       nbteh1 = 0
 334       nbteh2 = 0
 335       nbteh3 = 0
 336       nbteh4 = 0
 337       nbtep0 = 0
 338       nbtep1 = 0
 339       nbtep2 = 0
 340       nbtep3 = 0
 341       nbtep4 = 0
 342       nbtep5 = 0
 343       nbtedh = 0
 344       nbtedp = 0
 345 c     nbtede = non modifie
 346 c     nbtema = non modifie
 347 c     nbtepe = non modifie
 348       nbteto = nbtepe
 349       nbtecf = nbteto
 350       nbteca = 0
 351 c
 352 c 2.7. commun "nombpy" --> pyramides
 353 c     . chaque suppression de conformite des hexaedres supprime toutes
 354 c       les pyramides concernees
 355 c     . chaque suppression de conformite des pentaedres supprime toutes
 356 c       les pyramides concernees
 357 c     Autrement dit, nbpyto = nbpyac = 0 en sortie
 358 c
 359       iaux = nbpyh1 + nbpyh2 + nbpyh3 + nbpyh4
 360      >     + nbpyp0 + nbpyp1 + nbpyp2 + nbpyp3 + nbpyp4 + nbpyp5
 361      >     + nbpydh + nbpydp
 362 cgn      write (ulsort,90002) 'nombre de pyramides a supprimer', iaux
 363       nbpyac = nbpyac - iaux
 364       nbpyh1 = 0
 365       nbpyh2 = 0
 366       nbpyh3 = 0
 367       nbpyh4 = 0
 368       nbpyp0 = 0
 369       nbpyp1 = 0
 370       nbpyp2 = 0
 371       nbpyp3 = 0
 372       nbpyp4 = 0
 373       nbpyp5 = 0
 374       nbpydh = 0
 375       nbpydp = 0
 376 c     nbpyma = non modifie
 377 c     nbpype = non modifie
 378       nbpyto = nbpype
 379       nbpycf = nbpyto
 380       nbpyca = 0
 381 c
 382 c 2.8. commun "nombpe" --> pentaedres
 383 c
 384       iaux = nbpedp - nbpeco
 385 c
 386       nbpeac = nbpeac - iaux
 387       nbpeco = 0
 388       nbpedp = 0
 389 c     nbpede = non modifie
 390 c     nbpema = non modifie
 391 c     nbpepe = non modifie
 392       nbpeto = nbpepe
 393       nbpecf = nbpeto
 394       nbpeca = 0
 395 c
 396 c====
 397 c 3. impressions
 398 c====
 399 c
 400       write(ulsort,texte(langue,4)) mess14(langue,3,-1), nbnoto
 401       write(ulsort,texte(langue,5)) mess14(langue,3,1), nbarac
 402       if ( nbtrto.ne.0 .or. nbquto.ne.0 ) then
 403         write(ulsort,texte(langue,5)) mess14(langue,3,2), nbtrac
 404       endif
 405       if ( nbquto.ne.0 ) then
 406         write(ulsort,texte(langue,5)) mess14(langue,3,4), nbquac
 407       endif
 408       if ( nbteto.ne.0 ) then
 409         write(ulsort,texte(langue,5)) mess14(langue,3,3), nbteac
 410       endif
 411       if ( nbheto.ne.0 ) then
 412         write(ulsort,texte(langue,5)) mess14(langue,3,6), nbheac
 413       endif
 414       if ( nbpeto.ne.0 ) then
 415         write(ulsort,texte(langue,5)) mess14(langue,3,7), nbpeac
 416       endif
 417       if ( nbpyto.ne.0 ) then
 418         write(ulsort,texte(langue,5)) mess14(langue,3,5), nbpyac
 419       endif
 420       write(ulsort,*) ' '
 421 c
 422 c====
 423 c 4. stockage dans l'objet maillage
 424 c====
 425 #ifdef _DEBUG_HOMARD_
 426       write (ulsort,*) '5. stockage ; codret =', codret
 427 #endif
 428 c
 429       if ( codret.eq.0 ) then
 430 c
 431       call gmecat ( nhnoeu, 1, nbnoto, codre1 )
 432       call gmecat ( nharet, 1, nbarto, codre2 )
 433       call gmecat ( nhtria, 1, nbtrto, codre3 )
 434       call gmecat ( nhquad, 1, nbquto, codre4 )
 435       call gmecat ( nhtetr, 1, nbteto, codre5 )
 436       call gmecat ( nhhexa, 1, nbheto, codre6 )
 437       call gmecat ( nhpyra, 1, nbpyto, codre7 )
 438       call gmecat ( nhpent, 1, nbpeto, codre8 )
 439 c
 440       codre0 = min ( codre1, codre2, codre3, codre4, codre5,
 441      >               codre6, codre7, codre8 )
 442       codret = max ( abs(codre0), codret,
 443      >               codre1, codre2, codre3, codre4, codre5,
 444      >               codre6, codre7, codre8 )
 445 c
 446       call gmecat ( nhtetr, 2, nbteca, codre1 )
 447       call gmecat ( nhhexa, 2, nbheca, codre2 )
 448       call gmecat ( nhpyra, 2, nbpyca, codre3 )
 449       call gmecat ( nhpent, 2, nbpeca, codre4 )
 450 c
 451       codre0 = min ( codre1, codre2, codre3, codre4 )
 452       codret = max ( abs(codre0), codret,
 453      >               codre1, codre2, codre3, codre4 )
 454 c
 455 c
 456       endif
 457 c
 458 c====
 459 c 5. la fin
 460 c====
 461 c
 462       if ( codret.ne.0 ) then
 463 c
 464 #include "envex2.h"
 465       write (ulsort,texte(langue,1)) 'Sortie', nompro
 466       write (ulsort,texte(langue,2)) codret
 467       endif
 468 c
 469 #ifdef _DEBUG_HOMARD_
 470       write (ulsort,texte(langue,1)) 'Sortie', nompro
 471       call dmflsh (iaux)
 472 #endif
 473 c
 474       end