src/tool/Decision/dehom1.F

   1       subroutine dehom1 ( pilraf, pilder,
   2      >                    hetare,
   3      >                    hettri, aretri,
   4      >                    hetqua, arequa,
   5      >                    arehom, homtri, quahom,
   6      >                    decare, decfac,
   7      >                    ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c traitement des DEcisions - HOMologue - phase 1
  29 c                --          ---               -
  30 c     rmq : on ne peut pas utiliser les tables ho1are ... car elle ne
  31 c           sont plus a jour apres suppression de la conformite
  32 c
  33 c     rmq : le raffinement est prioritaire sur le deraffinement
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . pilraf . e   .   1    . pilotage du raffinement                    .
  39 c .        .     .        . -1 : raffinement uniforme                  .
  40 c .        .     .        .  0 : pas de raffinement                    .
  41 c .        .     .        .  1 : raffinement libre                     .
  42 c .        .     .        .  2 : raff. libre homogene en type d'element.
  43 c . pilder . e   .   1    . pilotage du deraffinement                  .
  44 c .        .     .        . -1 : deraffinement uniforme                .
  45 c .        .     .        .  0 : pas de deraffinement                  .
  46 c .        .     .        .  1 : deraffinement libre                   .
  47 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  48 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  49 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  50 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  51 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  52 c . arehom . e   . nbarto . ensemble des aretes homologues             .
  53 c . homtri . e   . nbtrto . ensemble des triangles homologues          .
  54 c . quahom . e   . nbquto . ensemble des quadrangles homologues        .
  55 c . decare . es  . nbarto . decisions des aretes                       .
  56 c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
  57 c .        .     . :nbtrto.                                            .
  58 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  59 c . langue . e   .    1   . langue des messages                        .
  60 c .        .     .        . 1 : francais, 2 : anglais                  .
  61 c . codret .  s  .    1   . code de retour des modules                 .
  62 c .        .     .        . 0 : pas de probleme                        .
  63 c .        .     .        . 1 : probleme                               .
  64 c ______________________________________________________________________
  65 c
  66 c====
  67 c 0. declarations et dimensionnement
  68 c====
  69 c
  70 c 0.1. ==> generalites
  71 c
  72       implicit none
  73       save
  74 c
  75       character*6 nompro
  76       parameter ( nompro = 'DEHOM1' )
  77 c
  78 #include "nblang.h"
  79 c
  80 c 0.2. ==> communs
  81 c
  82 #include "envex1.h"
  83 c
  84 #include "nombar.h"
  85 #include "nombtr.h"
  86 #include "nombqu.h"
  87 #include "envada.h"
  88 #include "envca1.h"
  89 #include "impr02.h"
  90 c
  91 c 0.3. ==> arguments
  92 c
  93       integer pilraf, pilder
  94       integer hetare(nbarto)
  95       integer hettri(nbtrto), aretri(nbtrto,3)
  96       integer hetqua(nbquto), arequa(nbquto,4)
  97       integer arehom(nbarto), homtri(nbtrto), quahom(nbquto)
  98       integer decare(0:nbarto), decfac(-nbquto:nbtrto)
  99 c
 100       integer ulsort, langue, codret
 101 c
 102 c 0.4. ==> variables locales
 103 c
 104       integer iaux
 105       integer arete1, arete2, face1, face2a, face2d, laface
 106       integer arete(4)
 107       integer etatar, etatfa
 108       integer areloc, letria
 109       integer nbarhd, nbarhg, nbarhr
 110       integer nbtrhd, nbtrhr
 111       integer nbquhd, nbquhr
 112       integer option, nbento, nbaret
 113 c
 114       logical afaire
 115 c
 116       integer nbmess
 117       parameter (nbmess = 10 )
 118       character*80 texte(nblang,nbmess)
 119 c ______________________________________________________________________
 120 c
 121 c====
 122 c 1. messages
 123 c====
 124 c
 125 #include "impr01.h"
 126 c
 127 #ifdef _DEBUG_HOMARD_
 128       write (ulsort,texte(langue,1)) 'Entree', nompro
 129       call dmflsh (iaux)
 130 #endif
 131 c
 132       texte(1,4) =
 133      >'(/,7x,''Nombre de '',a,''a garder par equivalence    :'',i10)'
 134       texte(1,5) =
 135      >'(/,7x,''Nombre de '',a,''a decouper par equivalence  :'',i10)'
 136       texte(1,6) =
 137      >'(/,7x,''Nombre de '',a,''a reactiver par equivalence :'',i10)'
 138 c
 139       texte(2,4) =
 140      > '(/,7x,a,'' to keep due to equivalence       :'',i10)'
 141       texte(2,5) =
 142      > '(/,7x,a,'' to divide due to equivalence     :'',i10)'
 143       texte(2,6) =
 144      > '(/,7x,a,'' to reactivate due to equivalence :'',i10)'
 145 c
 146       codret = 0
 147 c
 148       nbarhg = 0
 149       nbarhr = 0
 150       nbarhd = 0
 151 c
 152       nbtrhd = 0
 153       nbtrhr = 0
 154 c
 155       nbquhd = 0
 156       nbquhr = 0
 157 c
 158 c====
 159 c 2. dans le cas de deux aretes homologues, dont l'une est a reactiver
 160 c    et l'autre doit etre maintenue parce elle borde une face a couper :
 161 c    il faut empecher le deraffinement.
 162 c    cela se produit apres une suppression de conformite
 163 c
 164 c     chiffres arabes  : decision sur les faces (decfac)
 165 c     chiffres romains : decision sur les aretes (decare)
 166 c     x : noeuds
 167 c
 168 c       maillage n : on derafine a gauche et on raffine a droite
 169 c       apres l'initialisation des decisions on en est a :
 170 c
 171 c                x                             x
 172 c               . .                           ...
 173 c              .   .                         . . .
 174 c             . -1  .         <-->          .  .  .
 175 c         -I x.......x -I                I .   .   . I
 176 c           . .     . .                   .    .    .
 177 c          .   .-1 .   .                 .   1 . 0   .
 178 c         . -1  . . -1  .               .      .      .
 179 c        .       .       .             .       .       .
 180 c       x--------x--------x           x--------x--------x
 181 c               -I                             0
 182 c
 183 c
 184 c       maillage n apres suppression de la conformite :
 185 c
 186 c                x                             x
 187 c               . .                           . .
 188 c              .   .                         .   .
 189 c             . -1  .         <-->          .     .
 190 c         -I x.......x -I                I .       . I
 191 c           . .     . .                   .         .
 192 c          .   .-1 .   .                 .     1     .
 193 c         . -1  . . -1  .               .             .
 194 c        .       .       .             .               .
 195 c       x--------x--------x           x--------x--------x
 196 c               -I                             0
 197 c
 198 c       Il faut donc inhiber le -I sur l'arete homologue de gauche :
 199 c
 200 c                x                             x
 201 c               . .                           . .
 202 c              .   .                         .   .
 203 c             . -1  .         <-->          .     .
 204 c         -I x.......x -I                I .       . I
 205 c           . .     . .                   .         .
 206 c          .   .-1 .   .                 .     1     .
 207 c         . -1  . . -1  .               .             .
 208 c        .       .       .             .               .
 209 c       x--------x--------x           x--------x--------x
 210 c                0                             0
 211 c
 212 c       pour obtenir :
 213 c
 214 c
 215 c                x                             x
 216 c               ...                           . .
 217 c              . . .                         .   .
 218 c             .  .  .         <-->          .     .
 219 c            .   .   .                   I .       . I
 220 c           .    .    .                   .         .
 221 c          .     .     .                 .     1     .
 222 c         .      .      .               .             .
 223 c        .       .       .             .               .
 224 c       x--------x--------x           x--------x--------x
 225 c
 226 c     il faut commencer par cette inhibition et ensuite seulement
 227 c     transferer arete par arete
 228 c===
 229 c
 230       if ( homolo.ge.2 ) then
 231 c
 232       if ( pilder.gt.0 .and. nbiter.ne.0 ) then
 233 c
 234       do 21, letria = 1, nbtrto
 235 c
 236         if ( decfac(letria).eq.4 ) then
 237 c
 238           do 211 , areloc = 1, 3
 239             arete1 = aretri(letria,areloc)
 240             arete2 = abs(arehom(arete1))
 241             if ( arete2.ne.0 ) then
 242               if ( decare(arete2).eq.-1 ) then
 243                 decare(arete2) = 0
 244                 nbarhg = nbarhg + 1
 245 #ifdef _DEBUG_HOMARD_
 246            write(ulsort,*) 'Gar. arete1 = ',arete1,' ==> arete2 ',arete2
 247 #endif
 248               endif
 249             endif
 250   211     continue
 251 c
 252         endif
 253 c
 254    21 continue
 255 c
 256       endif
 257 c
 258       endif
 259 c
 260 c====
 261 c 3. on complete les tables de decisions pour les faces en 3D
 262 c    attention, il faut le faire avant les aretes pour pouvoir unifier
 263 c    les decisions sur toutes les aretes
 264 c====
 265 c
 266       if ( homolo.ge.3 ) then
 267 c
 268       do 3 , option = 2, 4, 2
 269 c
 270         if ( option.eq.2 ) then
 271           nbento = nbtrto
 272           nbaret = 3
 273         else
 274           nbento = nbquto
 275           nbaret = 4
 276         endif
 277 c
 278         do 30, face1 = 1 , nbento
 279 c
 280           if ( option.eq.2) then
 281             laface = face1
 282             face2a = abs(homtri(face1))
 283             face2d = face2a
 284           else
 285             laface = -face1
 286             face2a = abs(quahom(face1))
 287             face2d = -face2a
 288           endif
 289 c
 290           if ( face2a.ne.0 ) then
 291 c
 292 c 3.1. ==> unification du deraffinement
 293 c
 294             if ( decfac(laface).eq.-1 .and. decfac(face2d).eq.0 ) then
 295 c
 296 c 3.1.1. ==> on controle si toutes les aretes de face2 sont a deraffiner
 297 c            ou a garder
 298 c
 299               afaire = .true.
 300               if ( option.eq.2) then
 301                 do 311 , areloc = 1, nbaret
 302                   arete(areloc) = aretri(face2a,areloc)
 303   311           continue
 304               else
 305                 do 312 , areloc = 1, nbaret
 306                   arete(areloc) = arequa(face2a,areloc)
 307   312           continue
 308               endif
 309 c
 310               do 313 , areloc = 1, nbaret
 311                 if ( decare(arete(areloc)).gt.0 ) then
 312                   afaire = .false.
 313                 endif
 314   313         continue
 315 c
 316 c 3.1.2. ==> les aretes de face2 sont toutes a deraffiner ==> on
 317 c            deraffine la face face2 et ses aretes
 318 c
 319               if ( afaire ) then
 320 #ifdef _DEBUG_HOMARD_
 321             write(ulsort,*) 'Der. face1 = ',laface,' ==> face2 ',face2d
 322 #endif
 323                 decfac(face2d) = -1
 324                 if ( option.eq.2 ) then
 325                   nbtrhd = nbtrhd + 1
 326                 else
 327                   nbquhd = nbquhd + 1
 328                 endif
 329 c
 330                 do 314 , areloc = 1, nbaret
 331                   if ( decare(arete(areloc)).ne.-1 ) then
 332                     decare(arete(areloc)) = -1
 333                     nbarhg = nbarhg + 1
 334 #ifdef _DEBUG_HOMARD_
 335                     write(ulsort,*) 'Der. arete1 = ',arete(areloc)
 336 #endif
 337                   endif
 338   314           continue
 339               endif
 340 c
 341             endif
 342 c
 343 c 3.2. ==> unification du raffinement
 344 c
 345             if ( decfac(laface).eq.4 .and. decfac(face2d).ne.4 ) then
 346 c
 347               if ( option.eq.2 ) then
 348                 etatfa = mod(hettri(face2a),10)
 349               else
 350                 etatfa = mod(hetqua(face2a),100)
 351               endif
 352               if ( etatfa.eq.0 ) then
 353                 decfac(face2d) = 4
 354                 if ( option.eq.2 ) then
 355                   nbtrhr = nbtrhr + 1
 356                 else
 357                   nbquhr = nbquhr + 1
 358                 endif
 359 #ifdef _DEBUG_HOMARD_
 360             write(ulsort,*) 'Raf. face1 = ',laface,' ==> face2 ',face2d
 361 #endif
 362               endif
 363 c
 364               do 321 , areloc = 1, nbaret
 365                 if ( option.eq.2 ) then
 366                   arete1 = aretri(face2a,areloc)
 367                 else
 368                   arete1 = arequa(face2a,areloc)
 369                 endif
 370                 etatar = mod( hetare(arete1) , 10 )
 371                 if ( decare(arete1).ne.2 .and. etatar.eq.0 ) then
 372                   decare(arete1) = 2
 373                   nbarhd = nbarhd + 1
 374 #ifdef _DEBUG_HOMARD_
 375                   write(ulsort,*) '  ==> Raf. arete1 = ',arete1
 376 #endif
 377                 endif
 378   321         continue
 379 c
 380             endif
 381 c
 382           endif
 383 c
 384    30   continue
 385 c
 386     3 continue
 387 c
 388       endif
 389 c
 390 c====
 391 c 4. on complete les tables de decisions pour les aretes
 392 c     pour chaque entite qui est "a decouper" et qui possede une entite
 393 c     homologue, on declare "a decouper" l'entite homologue si elle ne
 394 c     l'est pas deja (ce qui permet d'en faire le compte)
 395 c====
 396 c
 397       if ( homolo.ge.2 ) then
 398 c
 399       do 41, arete1 = 1, nbarto
 400 c
 401         arete2 = abs(arehom(arete1))
 402 c
 403         if ( arete2.ne.0 ) then
 404 c
 405 c 4.1. ==> unification du deraffinement
 406 c         A condition que l'arete homologue ne soit pas grand-mere !
 407 c         Sinon, on inhibe le deraffinement sur la premiere
 408 c
 409           if ( decare(arete1).eq.-1 .and. decare(arete2).eq.0 ) then
 410             etatar = mod( hetare(arete2) , 10 )
 411             if ( etatar.eq.9 ) then
 412               decare(arete1) = 0
 413               nbarhg = nbarhg + 1
 414             else
 415 #ifdef _DEBUG_HOMARD_
 416            write(ulsort,*) 'Der. arete1 = ',arete1,' ==> arete2 ',arete2
 417 #endif
 418               decare(arete2) = -1
 419               nbarhd = nbarhd + 1
 420             endif
 421           endif
 422 c
 423 c 4.2. ==> unification du raffinement
 424 c
 425           if ( decare(arete1).eq.2 .and. decare(arete2).ne.2 ) then
 426             etatar = mod( hetare(arete2) , 10 )
 427             if ( etatar.eq.0 ) then
 428 #ifdef _DEBUG_HOMARD_
 429            write(ulsort,*) 'Raf. arete1 = ',arete1,' ==> arete2 ',arete2
 430 #endif
 431               decare(arete2) = 2
 432               nbarhr = nbarhr + 1
 433             endif
 434           endif
 435         endif
 436 c
 437    41 continue
 438 c
 439       endif
 440 c
 441 c====
 442 c 5. messages
 443 c====
 444 c
 445       if ( homolo.ge.2 ) then
 446 c
 447       if ( pilder.gt.0 ) then
 448         write(ulsort,texte(langue,6)) mess14(langue,3,1), nbarhd
 449         write(ulsort,texte(langue,4)) mess14(langue,3,1), nbarhg
 450       endif
 451       if ( pilraf.gt.0 ) then
 452         write(ulsort,texte(langue,5)) mess14(langue,3,1), nbarhr
 453       endif
 454 c
 455       endif
 456 c
 457       if ( homolo.ge.3 ) then
 458 c
 459       if ( pilder.gt.0 ) then
 460         if ( nbtrto.gt.0 ) then
 461           write(ulsort,texte(langue,4)) mess14(langue,3,2), nbtrhd
 462         endif
 463         if ( nbquto.gt.0 ) then
 464           write(ulsort,texte(langue,4)) mess14(langue,3,4), nbquhd
 465         endif
 466       endif
 467       if ( pilraf.gt.0 ) then
 468         if ( nbtrto.gt.0 ) then
 469           write(ulsort,texte(langue,5)) mess14(langue,3,2), nbtrhr
 470         endif
 471         if ( nbquto.gt.0 ) then
 472           write(ulsort,texte(langue,5)) mess14(langue,3,4), nbquhr
 473         endif
 474       endif
 475 c
 476       endif
 477 c
 478 c====
 479 c 6. la fin
 480 c====
 481 c
 482       if ( codret.ne.0 ) then
 483 c
 484 #include "envex2.h"
 485 c
 486       write (ulsort,texte(langue,1)) 'Sortie', nompro
 487       write (ulsort,texte(langue,2)) codret
 488 c
 489       endif
 490 c
 491 #ifdef _DEBUG_HOMARD_
 492       write (ulsort,texte(langue,1)) 'Sortie', nompro
 493       call dmflsh (iaux)
 494 #endif
 495 c
 496       end