src/tool/Creation_Maillage/cmhomt.F

   1       subroutine cmhomt ( arehom, trihom,
   2      >                    somare,
   3      >                    aretri, filtri, hettri,
   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    Creation du Maillage - HOMologues - les Triangles
  26 c    -           -          ---              -
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . arehom . es  . nbarto . ensemble des aretes homologues             .
  32 c . trihom . es  . nbtrto . ensemble des triangles homologues          .
  33 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  34 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  35 c . filtri . e   . nbtrto . premier fils des triangles                 .
  36 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  37 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  38 c . langue . e   .    1   . langue des messages                        .
  39 c .        .     .        . 1 : francais, 2 : anglais                  .
  40 c . codret . es  .    1   . code de retour des modules                 .
  41 c .        .     .        . 0 : pas de probleme                        .
  42 c ______________________________________________________________________
  43 c
  44 c====
  45 c 0. declarations et dimensionnement
  46 c====
  47 c
  48 c 0.1. ==> generalites
  49 c
  50       implicit none
  51       save
  52 c
  53       character*6 nompro
  54       parameter ( nompro = 'CMHOMT' )
  55 c
  56 #include "nblang.h"
  57 c
  58 c 0.2. ==> communs
  59 c
  60 #include "envex1.h"
  61 c
  62 #include "demitr.h"
  63 #include "nombar.h"
  64 #include "nombtr.h"
  65 #include "impr02.h"
  66 c
  67 c 0.3. ==> arguments
  68 c
  69       integer arehom(nbarto), trihom(nbtrto)
  70       integer somare(2,nbarto)
  71       integer aretri(nbtrto,3), filtri(nbtrto), hettri(nbtrto)
  72 c
  73       integer ulsort, langue, codret
  74 c
  75 c 0.4. ==> variables locales
  76 c
  77       integer iaux
  78       integer letria
  79       integer fach
  80       integer hist, etafac, etafho, an2, an1, n2f, n1f
  81       integer a2f1, a2f2, a2f3, a1f1, a1f2, a1f3
  82       integer f2k, f2j, f1k, f1j
  83       integer na2k, na1k, na1j
  84       integer a2s2s3, a2s1s3
  85       integer a1s1s2, a1s2s3, a1s1s3
  86 c
  87       integer nbmess
  88       parameter ( nbmess = 10 )
  89       character*80 texte(nblang,nbmess)
  90 c
  91 c 0.5. ==> initialisations
  92 c ______________________________________________________________________
  93 c
  94 c====
  95 c 1. initialisations
  96 c====
  97 c
  98 #include "impr01.h"
  99 c
 100 #ifdef _DEBUG_HOMARD_
 101       write (ulsort,texte(langue,1)) 'Entree', nompro
 102       call dmflsh (iaux)
 103 #endif
 104 c
 105       texte(1,4) = '(''Etat du '',a,i10,'' : '',i4)'
 106       texte(1,5) = '(/,''Les deux '',a,'' homologues'',2i10)'
 107       texte(1,6) = '(''devraient etre coupes en 2.'')'
 108       texte(1,7) = '(''Elle a pour homologue '',i10)'
 109       texte(1,8) = '(''Il faudrait l''''arete'',i10,'' ou '',i10)'
 110       texte(1,9) = '(''Arete'',i10,'' de sommets'',2i10)'
 111       texte(1,10) = '(5x,''Erreur sur les '',a,'' homologues.'')'
 112 c
 113       texte(2,4) = '(''State of '',a,'' #'',i10,'' : '',i4)'
 114       texte(2,5) = '(/,''The two homologous '',a,'' #'',i10)'
 115       texte(2,6) = '(''should be cut into 2.'')'
 116       texte(2,7) = '(''Its homologous is ''i10)'
 117       texte(2,8) = '(''It should be edge #'',i10,'' or #'',i10)'
 118       texte(2,9) = '(''Edge #'',i10,'' with vertices #'',2i10)'
 119       texte(2,10) = '(5x,''Error for homologous '',a)'
 120 c
 121 c====
 122 c 2. on boucle uniquement sur les triangles de la face periodique 2
 123 c    qui viennent d'etre decoupes en 2 ou en 4
 124 c====
 125 c
 126       do 21, letria = 1, nbtrpe
 127 c
 128         if ( trihom(letria).gt.0 ) then
 129 c
 130           hist = hettri(letria)
 131           etafac = mod ( hist, 10 )
 132 c
 133           if ( hist.eq. 4 .or. hist.eq.14 .or.
 134      >         hist.eq.24 .or. hist.eq.34 ) then
 135 c
 136             fach = abs(trihom(letria))
 137 c
 138 c 2.1. ==> le triangle vient d'etre decoupe en 4
 139 c
 140 c 2.1.1. ==> recuperation des infos sur les fils de letria
 141 c
 142             n2f = filtri(letria)
 143 c
 144 c           recuperation des numeros d'aretes
 145 c
 146             a2s2s3 = aretri(letria,1)
 147             a2s1s3 = aretri(letria,2)
 148 c
 149 c           recuperation des aretes internes
 150 c
 151             a2f1 = aretri(n2f,1)
 152             a2f2 = aretri(n2f,2)
 153             a2f3 = aretri(n2f,3)
 154 c
 155 c 2.1.2.  ==> recuperation des infos sur le triangle homologue
 156 c
 157             n1f = filtri(fach)
 158 c
 159 c           recuperation des numeros d'aretes
 160 c
 161             a1s1s2 = aretri(fach,3)
 162             a1s2s3 = aretri(fach,1)
 163             a1s1s3 = aretri(fach,2)
 164 c
 165 c           recuperation des aretes internes
 166 c
 167             a1f1 = aretri(n1f,1)
 168             a1f2 = aretri(n1f,2)
 169             a1f3 = aretri(n1f,3)
 170 c
 171 c 2.1.3.  ==> reperage des homologues
 172 c
 173 c           dans tous les cas on a correspondance entre
 174 c           les triangles n2f et n1f, fils aines.
 175 c           n2f est sur la meme face que "larete" c'est-a-dire la face 2
 176 c           donc noehom(n2f) est positif.
 177 c           s1f est sur l'autre face, donc noehom(s1f) est negatif
 178 c
 179             trihom(n2f) = n1f
 180             trihom(n1f) = -n2f
 181 c
 182             if ( abs(arehom(a2s2s3)).eq.a1s2s3 ) then
 183 c
 184 c             les aretes 1 correspondent donc on a correspondance entre
 185 c             les triangles n2f+1 et n1f+1
 186 c             les aretes a2f1 et a1f1
 187 c
 188               arehom(a2f1) = a1f1
 189               arehom(a1f1) = -a2f1
 190 c
 191               trihom(n2f+1) = (n1f+1)
 192               trihom(n1f+1) = -(n2f+1)
 193 c
 194               if ( abs(arehom(a2s1s3)).eq.a1s1s3 ) then
 195 c
 196 c               les aretes 2 correspondent donc
 197 c               on a correspondance entre
 198 c               les triangles n2f+2 et n1f+2
 199 c               les triangles n2f+3 et n1f+3
 200 c               les aretes a2f2 et a1f2
 201 c               les aretes a2f3 et a1f3
 202 c
 203                 arehom(a2f2) = a1f2
 204                 arehom(a1f2) = -a2f2
 205                 arehom(a2f3) = a1f3
 206                 arehom(a1f3) = -a2f3
 207 c
 208                 trihom(n2f+2) = (n1f+2)
 209                 trihom(n1f+2) = -(n2f+2)
 210                 trihom(n2f+3) = (n1f+3)
 211                 trihom(n1f+3) = -(n2f+3)
 212 c
 213               else
 214 c
 215 c               les aretes 2 et 3 correspondent
 216 c               donc on a correspondance entre
 217 c               les triangles n2f+2 et n1f+3
 218 c               les triangles n2f+3 et n1f+2
 219 c               les aretes a2f2 et a1f3
 220 c               les aretes a2f3 et a1f2
 221 c
 222                 arehom(a2f2) = a1f3
 223                 arehom(a1f3) = -a2f2
 224                 arehom(a2f3) = a1f2
 225                 arehom(a1f2) = -a2f3
 226 c
 227                 trihom(n2f+2) = (n1f+3)
 228                 trihom(n1f+3) = -(n2f+2)
 229                 trihom(n2f+3) = (n1f+2)
 230                 trihom(n1f+2) = -(n2f+3)
 231 c
 232               endif
 233 c
 234             elseif ( abs(arehom(a2s2s3)).eq.a1s1s3 ) then
 235 c
 236 c             les aretes 1 et 2 correspondent
 237 c             donc on a correspondance entre
 238 c             les triangles n2f+1 et n1f+2
 239 c             les aretes a2f1 et a1f2
 240 c
 241               arehom(a2f1) = a1f2
 242               arehom(a1f2) = -a2f1
 243 c
 244               trihom(n2f+1) = (n1f+2)
 245               trihom(n1f+2) = -(n2f+1)
 246 c
 247               if ( abs(arehom(a2s1s3)).eq.a1s2s3 ) then
 248 c
 249 c               les aretes 2 et 1 correspondent
 250 c               donc on a correspondance entre
 251 c               les triangles n2f+2 et n1f+1
 252 c               les triangles n2f+3 et n1f+3
 253 c               les aretes a2f2 et a1f1
 254 c               les aretes a2f3 et a1f3
 255 c
 256                 arehom(a2f2) = a1f1
 257                 arehom(a1f1) = -a2f2
 258                 arehom(a2f3) = a1f3
 259                 arehom(a1f3) = -a2f3
 260 c
 261                 trihom(n2f+2) = (n1f+1)
 262                 trihom(n1f+1) = -(n2f+2)
 263                 trihom(n2f+3) = (n1f+3)
 264                 trihom(n1f+3) = -(n2f+3)
 265 c
 266               else
 267 c
 268 c               les aretes 2 et 3 correspondent
 269 c               donc on a correspondance entre
 270 c               les triangles n2f+2 et n1f+3
 271 c               les triangles n2f+3 et n1f+1
 272 c               les aretes a2f2 et a1f3
 273 c               les aretes a2f3 et a1f1
 274 c
 275                 arehom(a2f2) = a1f3
 276                 arehom(a1f3) = -a2f2
 277                 arehom(a2f3) = a1f1
 278                 arehom(a1f1) = -a2f3
 279 c
 280                 trihom(n2f+2) = (n1f+3)
 281                 trihom(n1f+3) = -(n2f+2)
 282                 trihom(n2f+3) = (n1f+1)
 283                 trihom(n1f+1) = -(n2f+3)
 284 c
 285               endif
 286 c
 287             elseif ( abs(arehom(a2s2s3)).eq.a1s1s2 ) then
 288 c
 289 c             les aretes 1 et 3 correspondent
 290 c             donc on a correspondance entre
 291 c             les triangles n2f+1 et n1f+3
 292 c             les aretes a2f1 et a1f3
 293 c
 294               arehom(a2f1) = a1f3
 295               arehom(a1f3) = -a2f1
 296 c
 297               trihom(n2f+1) = (n1f+3)
 298               trihom(n1f+3) = -(n2f+1)
 299 c
 300               if ( abs(arehom(a2s1s3)).eq.a1s2s3 ) then
 301 c
 302 c               les aretes 2 et 1 correspondent
 303 c               donc on a correspondance entre
 304 c               les triangles n2f+2 et n1f+1
 305 c               les triangles n2f+3 et n1f+2
 306 c               les aretes a2f2 et a1f1
 307 c               les aretes a2f3 et a1f2
 308 c
 309                 arehom(a2f2) = a1f1
 310                 arehom(a1f1) = -a2f2
 311                 arehom(a2f3) = a1f2
 312                 arehom(a1f2) = -a2f3
 313 c
 314                 trihom(n2f+2) = (n1f+1)
 315                 trihom(n1f+1) = -(n2f+2)
 316                 trihom(n2f+3) = (n1f+2)
 317                 trihom(n1f+2) = -(n2f+3)
 318 c
 319               else
 320 c
 321 c               les aretes 2 correspondent
 322 c               donc on a correspondance entre
 323 c               les triangles n2f+2 et n1f+2
 324 c               les triangles n2f+3 et n1f+1
 325 c               les aretes a2f2 et a1f3
 326 c               les aretes a2f3 et a1f1
 327 c
 328                 arehom(a2f2) = a1f2
 329                 arehom(a1f2) = -a2f2
 330                 arehom(a2f3) = a1f1
 331                 arehom(a1f1) = -a2f3
 332 c
 333                 trihom(n2f+2) = (n1f+2)
 334                 trihom(n1f+2) = -(n2f+2)
 335                 trihom(n2f+3) = (n1f+1)
 336                 trihom(n1f+1) = -(n2f+3)
 337 c
 338               endif
 339 c
 340             else
 341               write (ulsort,texte(langue,10)) mess14(langue,3,2)
 342             endif
 343 c
 344           elseif ( etafac.eq.1 .or. etafac.eq.2 .or. etafac.eq.3 ) then
 345 c
 346 c 2.2. ==> le triangle vient d'etre decoupe en 2
 347 c          . il n'y a aucune regle d'ordre de creation des
 348 c          demi-triangles entre les deux meres homologues.
 349 c          . il n'y a pas de probleme d'axe a gerer, car letria est
 350 c          sur la face 2 par hypothese, et donc fach sur la face 1
 351 c          . la seule information dont on est certain est la
 352 c          correspondance entre les filles des aretes decoupees : le
 353 c          tableau arehom a ete mis a jour precedemment
 354 c
 355 c             letria                         fach
 356 c
 357 c               s2i                           s1i
 358 c                x                             x
 359 c               ...                           ...
 360 c              . . .                         . . .
 361 c       are2j .  .  . are2k   <-->    are1j .  .  . are1k
 362 c            .  a.   .                     .  a.   .
 363 c           .   n.    .                   .   n.    .
 364 c          .    2.     .                 .    1.     .
 365 c         . f2k  . f2j  .               . f1k  . f1j  .
 366 c        .       .       .             .       .       .
 367 c       x-----------------x           x-----------------x
 368 c     s2k  na2k n2  na2j  s2j       s1k na1k  n1  na1j  s1j
 369 c
 370 c        alternative :      f2k est homologue de f1k
 371 c                      ou : f2k est homologue de f1j
 372 c
 373 c 2.2.1. ==> recuperation des infos sur les fils de letria
 374 c
 375             if ( etafac.eq.1 ) then
 376 c
 377 c             le triangle a ete decoupe en 2 par l'arete numero 1
 378 c
 379 c             recuperation des triangles fils
 380 c
 381               f2k = filtri(letria) + nutrde(1,2)
 382               f2j = filtri(letria) + nutrde(1,3)
 383 c
 384 c             recuperation des nouvelles aretes
 385 c
 386               na2k = aretri(f2k,1)
 387 c
 388               an2 = aretri(f2k,3)
 389 c
 390             elseif ( etafac.eq.2 ) then
 391 c
 392 c             le triangle a ete decoupe en 2 par l'arete numero 2
 393 c
 394 c             recuperation des triangles fils
 395 c
 396               f2k = filtri(letria) + nutrde(2,3)
 397               f2j = filtri(letria) + nutrde(2,1)
 398 c
 399 c             recuperation des nouvelles aretes
 400 c
 401               na2k = aretri(f2k,2)
 402 c
 403               an2 = aretri(f2k,1)
 404 c
 405             elseif ( etafac.eq.3 ) then
 406 c
 407 c             le triangle a ete decoupe en 2 par l'arete numero 3
 408 c
 409 c             recuperation des triangles fils
 410 c
 411               f2k = filtri(letria) + nutrde(3,1)
 412               f2j = filtri(letria) + nutrde(3,2)
 413 c
 414 c             recuperation des nouvelles aretes
 415 c
 416               na2k = aretri(f2k,3)
 417 c
 418               an2 = aretri(f2k,2)
 419 c
 420             endif
 421 c
 422 c 2.2.2.  ==> recuperation des infos sur le triangle homologue
 423 c
 424             fach = abs(trihom(letria))
 425 c
 426             etafho = mod ( hettri(fach), 10 )
 427 c
 428             if ( etafho.eq.1 ) then
 429 c
 430 c             le triangle a ete decoupe en 2 par l'arete numero 1
 431 c
 432 c             recuperation des triangles fils
 433 c
 434               f1k = filtri(fach) + nutrde(1,2)
 435               f1j = filtri(fach) + nutrde(1,3)
 436 c
 437 c             recuperation des nouvelles aretes
 438 c
 439               na1k = aretri(f1k,1)
 440               na1j = aretri(f1j,1)
 441 c
 442               an1 = aretri(f1k,3)
 443 c
 444             elseif ( etafho.eq.2 ) then
 445 c
 446 c             le triangle a ete decoupe en 2 par l'arete numero 2
 447 c
 448 c             recuperation des triangles fils
 449 c
 450               f1k = filtri(fach) + nutrde(2,3)
 451               f1j = filtri(fach) + nutrde(2,1)
 452 c
 453 c             recuperation des nouvelles aretes
 454 c
 455               na1k = aretri(f1k,2)
 456               na1j = aretri(f1j,2)
 457 c
 458               an1 = aretri(f1k,1)
 459 c
 460             elseif ( etafho.eq.3 ) then
 461 c
 462 c             le triangle a ete decoupe en 2 par l'arete numero 3
 463 c
 464 c             recuperation des triangles fils
 465 c
 466               f1k = filtri(fach) + nutrde(3,1)
 467               f1j = filtri(fach) + nutrde(3,2)
 468 c
 469 c             recuperation des nouvelles aretes
 470 c
 471               na1k = aretri(f1k,3)
 472               na1j = aretri(f1j,3)
 473 c
 474               an1 = aretri(f1k,2)
 475 c
 476             else
 477 c
 478 c             le triangle homologue n'est pas coupe en deux ???
 479 c
 480               write (ulsort,texte(langue,5))mess14(langue,3,2),
 481      >                                      letria, fach
 482               write (ulsort,texte(langue,6))
 483               write (ulsort,texte(langue,4)) mess14(langue,1,2),
 484      >                                       letria, etafac
 485               write (ulsort,texte(langue,4)) mess14(langue,1,2),
 486      >                                       fach, etafho
 487               codret = 2
 488 c
 489             endif
 490 c
 491 c 2.2.3.  ==> reperage des homologues
 492 c
 493             arehom(an2) = an1
 494             arehom(an1) = -an2
 495 c
 496             if ( arehom(na2k).eq.na1k ) then
 497 c
 498               trihom(f2k) = f1k
 499               trihom(f2j) = f1j
 500               trihom(f1k) = -f2k
 501               trihom(f1j) = -f2j
 502 c
 503             elseif ( arehom(na2k).eq.na1j ) then
 504 c
 505               trihom(f2k) = f1j
 506               trihom(f2j) = f1k
 507               trihom(f1k) = -f2j
 508               trihom(f1j) = -f2k
 509 c
 510             else
 511 c
 512 c             l'arete n'a pas d'homologue ?
 513 c
 514               write (ulsort,texte(langue,5)) mess14(langue,3,2),
 515      >                                       letria, fach
 516               write (ulsort,texte(langue,9))
 517      >                              na2k, somare(1,na2k), somare(2,na2k)
 518               write (ulsort,texte(langue,7)) arehom(na2k)
 519               if ( arehom(na2k).ne.0 ) then
 520                 write (ulsort,texte(langue,9)) abs(arehom(na2k)),
 521      >          somare(1,abs(arehom(na2k))), somare(2,abs(arehom(na2k)))
 522               endif
 523               write (ulsort,texte(langue,8)) na1k, na1j
 524               write (ulsort,texte(langue,9))
 525      >                              na1k, somare(1,na1k), somare(2,na1k)
 526               write (ulsort,texte(langue,9))
 527      >                              na1j, somare(1,na1j), somare(2,na1j)
 528               codret = 2
 529 c
 530             endif
 531 c
 532           endif
 533 c
 534         endif
 535 c
 536    21 continue
 537 c
 538 c====
 539 c 3. la fin
 540 c====
 541 c
 542       if ( codret.ne.0 ) then
 543 c
 544 #include "envex2.h"
 545 c
 546       write (ulsort,texte(langue,1)) 'Sortie', nompro
 547       write (ulsort,texte(langue,2)) codret
 548 c
 549       endif
 550 c
 551 #ifdef _DEBUG_HOMARD_
 552       write (ulsort,texte(langue,1)) 'Sortie', nompro
 553       call dmflsh (iaux)
 554 #endif
 555 c
 556       end