src/tool/Decision/dehmaj.F

   1       subroutine dehmaj ( option,
   2      >                    hetnoe, hetare,
   3      >                    hettri, hetqua,
   4      >                    hettet, hethex,
   5      >                    hetpen, hetpyr,
   6      >                    ulsort, langue, codret )
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c traitement des DEcisions - Historique - Mis A Jour vraie
  28 c                --          -            -   - -
  29 c ______________________________________________________________________
  30 c
  31 c but : mise a jour effective des historiques
  32 c    de maniere generale, l'historique des etats est un nombre a 2k
  33 c    chiffres. les k premiers decrivent l'etat de l'entite avant le
  34 c    processus de raffinement/deraffinement. les k derniers decrivent
  35 c    l'etat apres. a ce stade, nous sommes au depart du processus. il
  36 c    faut basculer l'etat "apres" pour le maillage n vers ce qui va etre
  37 c    l'etat "avant" pour le maillage n+1. les k premiers chiffres sont
  38 c    donc remplaces par les k derniers. les k derniers chiffres
  39 c    decrivent alors l'etat courant, une fois les entites de mise en
  40 c    conformite supprimees.
  41 c ______________________________________________________________________
  42 c .        .     .        .                                            .
  43 c .  nom   . e/s . taille .           description                      .
  44 c .____________________________________________________________________.
  45 c . option . e   .    1   . 0 : tri selon la conformite                .
  46 c .        .     .        . 1 : transfert direct                       .
  47 c . hetnoe . es  . nbnoto . historique de l'etat des noeuds            .
  48 c . hetare . es  . nbarto . historique de l'etat des aretes            .
  49 c . hettri . es  . nbtrto . historique de l'etat des triangles         .
  50 c . hetqua . es  . nbquto . historique de l'etat des quadrangles       .
  51 c . hettet . es  . nbteto . historique de l'etat des tetraedres        .
  52 c . hethex . es  . nbheto . historique de l'etat des hexaedres         .
  53 c . hetpen . es  . nbpeto . historique de l'etat des pentaedres        .
  54 c . hetpyr . es  . nbpyto . historique de l'etat des pyramides         .
  55 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  56 c . langue . e   .    1   . langue des messages                        .
  57 c .        .     .        . 1 : francais, 2 : anglais                  .
  58 c . codret .  s  .    1   . code de retour des modules                 .
  59 c .        .     .        . 0 : pas de probleme                        .
  60 c .        .     .        . 1 : probleme                               .
  61 c ______________________________________________________________________
  62 c
  63 c====
  64 c 0. declarations et dimensionnement
  65 c====
  66 c
  67 c 0.1. ==> generalites
  68 c
  69       implicit none
  70       save
  71 c
  72       character*6 nompro
  73       parameter ( nompro = 'DEHMAJ' )
  74 c
  75 #include "nblang.h"
  76 c
  77 c 0.2. ==> communs
  78 c
  79 #include "envex1.h"
  80 c
  81 #include "nombar.h"
  82 #include "nombtr.h"
  83 #include "nombqu.h"
  84 #include "nombno.h"
  85 #include "nombte.h"
  86 #include "nombhe.h"
  87 #include "nombpy.h"
  88 #include "nombpe.h"
  89 #include "impr02.h"
  90 c
  91 c 0.3. ==> arguments
  92 c
  93       integer option
  94       integer hetnoe(nbnoto)
  95       integer hetare(nbarto)
  96       integer hettri(nbtrto)
  97       integer hetqua(nbquto)
  98       integer hettet(nbteto)
  99       integer hethex(nbheto)
 100       integer hetpen(nbpeto)
 101       integer hetpyr(nbpyto)
 102 c
 103       integer ulsort, langue, codret
 104 c
 105 c 0.4. ==> variables locales
 106 c
 107       integer iaux, jaux
 108       integer etat
 109 c
 110       integer nbmess
 111       parameter (nbmess = 10 )
 112       character*80 texte(nblang,nbmess)
 113 c ______________________________________________________________________
 114 c
 115 c====
 116 c 1. messages
 117 c====
 118 c
 119 #include "impr01.h"
 120 c
 121 #ifdef _DEBUG_HOMARD_
 122       write (ulsort,texte(langue,1)) 'Entree', nompro
 123       call dmflsh (iaux)
 124 #endif
 125 c
 126       texte(1,4) =
 127      > '(5x,''Nombre d''''entites dont on modifie l''''historique'')'
 128 c
 129       texte(2,4) =
 130      > '(5x,''Number of entities whose history is modified'')'
 131 c
 132 10000 format(7x,a,' : ',i10)
 133 10001 format(1x)
 134 c
 135       codret = 0
 136 c
 137       write (ulsort,texte(langue,4))
 138 #ifdef _DEBUG_HOMARD_
 139       write (ulsort,10000) 'Option', option
 140 #endif
 141 c
 142 c====
 143 c 1. historique des noeuds
 144 c
 145 c   |------------------|----------------------------------------------|
 146 c   |      etat        |         description                          |
 147 c   |------------------|----------------------------------------------|
 148 c   |       0          | noeud isole                                  |
 149 c   |       1          | degre 1 = p1                                 |
 150 c   |       2          | degre 2 = p2                                 |
 151 c   |       3          | noeud de maille-point uniquement             |
 152 c   |       5          | inexistant                                   |
 153 c   |       9          | detruit                                      |
 154 c   |------------------|----------------------------------------------|
 155 c
 156 c====
 157 c
 158       write (ulsort,10000) mess14(langue,4,-1), nbnoto
 159 c
 160       do 10 , iaux = 1 , nbnoto
 161 c
 162         etat = mod(hetnoe(iaux),10)
 163 c
 164         hetnoe(iaux) = etat * 11
 165 c
 166    10 continue
 167 c
 168 c====
 169 c 2. historique des aretes
 170 c
 171 c   |------------------|----------------------------------------------|
 172 c   |      etat        |         description                          |
 173 c   |------------------|----------------------------------------------|
 174 c   |       0          | active                                       |
 175 c   |       2          | coupee en 2 et ses 2 filles sont actives     |
 176 c   |       5          | inexistante                                  |
 177 c   |       9          | coupee en 2 et un de ses filles est inactive |
 178 c   |------------------|----------------------------------------------|
 179 c
 180 c====
 181 c
 182       write (ulsort,10000) mess14(langue,4,1), nbarto
 183 c
 184       do 20 , iaux = 1 , nbarto
 185 c
 186         etat = mod(hetare(iaux),10)
 187 c
 188         hetare(iaux) = etat * 11
 189 c
 190    20 continue
 191 c
 192 c====
 193 c 3. historique des triangles
 194 c
 195 c   |------------------|----------------------------------------------|
 196 c   |      etat        |         description                          |
 197 c   |------------------|----------------------------------------------|
 198 c   |       0          | actif                                        |
 199 c   |       1          | coupe en 2 par sa premiere arete             |
 200 c   |       2          | coupe en 2 par sa deuxieme arete             |
 201 c   |       3          | coupe en 2 par sa troisieme arete            |
 202 c   |       4          | coupe en 4 et ses 4 fils sont actifs         |
 203 c   |       5          | inexistant                                   |
 204 c   |       6          | coupe en 4 et bascule de la premiere arete   |
 205 c   |                  | ses 4 fils sont actifs                       |
 206 c   |       7          | idem avec la deuxieme arete                  |
 207 c   |       8          | idem avec la troisieme arete                 |
 208 c   |       9          | coupe en 4 et un de ses fils est inactif     |
 209 c   |------------------|----------------------------------------------|
 210 c
 211 c====
 212 c
 213       if ( nbtrto.ne.0 ) then
 214 c
 215         write (ulsort,10000) mess14(langue,4,2), nbtrto
 216 c
 217         jaux = 10 + option
 218 c
 219         do 30 , iaux = 1 , nbtrto
 220 c
 221           etat = mod(hettri(iaux),10)
 222 c
 223           if ( etat.lt.4 ) then
 224             hettri(iaux) = etat * jaux
 225           else
 226             hettri(iaux) = etat * 11
 227           endif
 228 c
 229    30   continue
 230 c
 231       endif
 232 c
 233 c====
 234 c 4. historique des quadrangles
 235 c
 236 c   |------------------|----------------------------------------------|
 237 c   |      etat        |         description                          |
 238 c   |------------------|----------------------------------------------|
 239 c   |       0          | actif                                        |
 240 c   |       4          | coupe en 4 et ses 4 fils sont actifs         |
 241 c   |      21          | coupe en 2 quadrangles par les aretes 1 et 3 |
 242 c   |      22          | coupe en 2 quadrangles par les aretes 2 et 4 |
 243 c   |      31          | coupe en 3 triangles par son arete numero 1  |
 244 c   |      32          | coupe en 3 triangles par son arete numero 2  |
 245 c   |      33          | coupe en 3 triangles par son arete numero 2  |
 246 c   |      34          | coupe en 3 triangles par son arete numero 4  |
 247 c   |      41          | coupe en 3 quadrangles par les aretes 1 et 2 |
 248 c   |      42          | coupe en 3 quadrangles par les aretes 2 et 3 |
 249 c   |      43          | coupe en 3 quadrangles par les aretes 3 et 4 |
 250 c   |      44          | coupe en 3 quadrangles par les aretes 4 et 1 |
 251 c   |      55          | inexistant                                   |
 252 c   |      99          | coupe en 4 et un de ses fils est inactif     |
 253 c   |------------------|----------------------------------------------|
 254 c
 255 c====
 256 c
 257       if ( nbquto.ne.0 ) then
 258 c
 259         write (ulsort,10000) mess14(langue,4,4), nbquto
 260 c
 261         jaux = 100 + option
 262 c
 263         do 40 , iaux = 1 , nbquto
 264 c
 265           etat = mod(hetqua(iaux),100)
 266 c
 267           if ( etat.ge.21 .and. etat.le.44 ) then
 268             hetqua(iaux) = etat * jaux
 269           else
 270             hetqua(iaux) = etat * 101
 271           endif
 272 c
 273    40   continue
 274 c
 275       endif
 276 c
 277 c====
 278 c 5. historique des tetraedres
 279 c
 280 c   |------------------|----------------------------------------------|
 281 c   |      etat        |         description                          |
 282 c   |------------------|----------------------------------------------|
 283 c   |       0          | actif                                        |
 284 c   | 2i i=1,2,3,4,5,6 | coupe en 2 par sa i-eme arete                |
 285 c   | 4i i=1,2,3,4     | coupe en 4 par sa i-eme face                 |
 286 c   | 4i i=5,6,7       | coupe en 4 par la diagonale 1-6,2-5,3-4      |
 287 c   |      55          | inexistant                                   |
 288 c   | 8i i=5,6,7       | coupe en 8 par la diagonale 1-6,2-5,3-4      |
 289 c   | 99               | coupe en 8 et un de ses fils est inactif     |
 290 c   |------------------|----------------------------------------------|
 291 c
 292 c====
 293 c
 294       if ( nbteto.ne.0 ) then
 295 c
 296         write (ulsort,10000) mess14(langue,4,3), nbteto
 297 c
 298         jaux = 100 + option
 299 c
 300         do 50 , iaux = 1 , nbteto
 301 c
 302           etat = mod(hettet(iaux),100)
 303 c
 304           if ( etat.lt.55 ) then
 305             hettet(iaux) = etat * jaux
 306           else
 307             hettet(iaux) = etat * 101
 308           endif
 309 c
 310    50   continue
 311 c
 312       endif
 313 c
 314 c====
 315 c 6. historique des hexaedres
 316 c
 317 c   |------------------|----------------------------------------------|
 318 c   |      etat        |         description                          |
 319 c   |------------------|----------------------------------------------|
 320 c   |       0          | actif                                        |
 321 c   |       5          | inexistant                                   |
 322 c   |       8          | coupe en 8                                   |
 323 c   |       9          | coupe en 8 et un de ses fils est inactif     |
 324 c   |      11          | coupe par conformite                         |
 325 c   |------------------|----------------------------------------------|
 326 c
 327 c====
 328 c
 329       if ( nbheto.ne.0 ) then
 330 c
 331         write (ulsort,10000) mess14(langue,4,6), nbheto
 332 c
 333         jaux = 1000 + option
 334 c
 335         do 60 , iaux = 1 , nbheto
 336 c
 337           etat = mod(hethex(iaux),1000)
 338 c
 339           if ( etat.ge.11 ) then
 340             hethex(iaux) = etat * jaux
 341           else
 342             hethex(iaux) = etat * 1001
 343           endif
 344 c
 345    60   continue
 346 c
 347       endif
 348 c
 349 c====
 350 c 7. historique des pyramides
 351 c
 352 c   |------------------|----------------------------------------------|
 353 c   |      etat        |         description                          |
 354 c   |------------------|----------------------------------------------|
 355 c   |       0          | active                                       |
 356 c   |------------------|----------------------------------------------|
 357 c
 358 c====
 359 c
 360       if ( nbpyto.ne.0 ) then
 361 c
 362         write (ulsort,10000) mess14(langue,4,5), nbpyto
 363 c
 364         jaux = 100 + option
 365 c
 366         do 70 , iaux = 1 , nbpyto
 367 c
 368           etat = mod(hetpyr(iaux),100)
 369 c
 370           if ( etat.eq.0 ) then
 371             hetpyr(iaux) = etat * jaux
 372           else
 373             codret = 70
 374           endif
 375 c
 376    70   continue
 377 c
 378       endif
 379 c
 380 c====
 381 c 8. historique des pentaedres
 382 c
 383 c   |------------------|----------------------------------------------|
 384 c   |      etat        |         description                          |
 385 c   |------------------|----------------------------------------------|
 386 c   |       0          | actif                                        |
 387 c   |  i i=1, ...,  6  | coupee par l'arete i                         |
 388 c   |  i i=17, 18, 19  | coupee par l'arete i-10                      |
 389 c   |  i i=21, ..., 26 | coupee par 2 aretes tria & quad              |
 390 c   |  i i=31, ..., 36 | coupee par 2 aretes tria & tria              |
 391 c   |  i i=43, 44, 45  | coupee par une face quad                     |
 392 c   |  i i=51, 52      | coupee par une face tria                     |
 393 c   |      55          | inexistant                                   |
 394 c   | 80               | coupe en 8                                   |
 395 c   | 99               | coupe en 8 et un de ses fils est inactif     |
 396 c   |------------------|----------------------------------------------|
 397 c
 398 c====
 399 c
 400       if ( nbpeto.ne.0 ) then
 401 c
 402         write (ulsort,10000) mess14(langue,4,7), nbpeto
 403 c
 404         jaux = 100 + option
 405 c
 406         do 80 , iaux = 1 , nbpeto
 407 c
 408           etat = mod(hetpen(iaux),100)
 409 c
 410           if ( etat.lt.55 ) then
 411             hetpen(iaux) = etat * jaux
 412           else
 413             hetpen(iaux) = etat * 101
 414           endif
 415 c
 416    80   continue
 417 c
 418       endif
 419 c
 420 c====
 421 c 9. la fin
 422 c====
 423 c
 424       write (ulsort,10001)
 425 c
 426       if ( codret.ne.0 ) then
 427 c
 428 #include "envex2.h"
 429 c
 430       write (ulsort,texte(langue,1)) 'Sortie', nompro
 431       write (ulsort,texte(langue,2)) codret
 432 c
 433       endif
 434 c
 435 #ifdef _DEBUG_HOMARD_
 436       write (ulsort,texte(langue,1)) 'Sortie', nompro
 437       call dmflsh (iaux)
 438 #endif
 439 c
 440       end