src/tool/Modification/mmag10.F

   1       subroutine mmag10 ( somare,
   2      >                    aretri,
   3      >                    tritet, cotrte,
   4      >                    nbjois, nbpejs, tbaux1, tbaux2,
   5      >                    tbau30, tbau40,
   6      >                    tbau31, tbau41,
   7      >                    nbduno, nbduar, nbdutr,
   8      >                    nbnotn, nbartn, nbtrtn, nbqutn,
   9      >                    nbtetn, nbpetn, nbhetn,
  10      >                    nbjoit, nbpejt, nbtrjt,
  11      >                    nbjoiq, nbhejq, nbqujq,
  12      >                    nbjp06, nbte06,
  13      >                    nbjp09, nbpe09,
  14      >                    nbjp12, nbhe12,
  15      >                    nbvojm,
  16      >                    tbaux5,
  17      >                    ntra51, ptra51, ntra52, ptra52,
  18      >                    ntra53, ptra53,
  19      >                    ulsort, langue, codret )
  20 c ______________________________________________________________________
  21 c
  22 c                             H O M A R D
  23 c
  24 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  25 c
  26 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  27 c aupres des huissiers de justice Simart et Lavoir a Clamart
  28 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  29 c aupres des huissiers de justice
  30 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  31 c
  32 c    HOMARD est une marque deposee d'Electricite de France
  33 c
  34 c Copyright EDF 1996
  35 c Copyright EDF 1998
  36 c Copyright EDF 2002
  37 c Copyright EDF 2020
  38 c ______________________________________________________________________
  39 c
  40 c    Modification de Maillage - AGregat - phase 1.0
  41 c    -               -          --              - -
  42 c    Connaissant le nombre et les caracteristiques des pentaedres
  43 c    a creer pour les joints simples :
  44 c    . Decompte du nombre de noeuds, aretes, quadrangles a creer
  45 c    . Decompte du nombre de joints multiples
  46 c ______________________________________________________________________
  47 c .        .     .        .                                            .
  48 c .  nom   . e/s . taille .           description                      .
  49 c .____________________________________________________________________.
  50 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  51 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  52 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  53 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  54 c . nbjois . e   .   1    . nombre de joints simples                   .
  55 c . nbpejs . e   .   1    . nombre de pentaedres de joints simples     .
  56 c . tbaux1 . e   .4*nbpejs. Pour le i-eme pentaedre de joint simple :  .
  57 c .        .     .        . (1,i) : numero du triangle a dupliquer     .
  58 c .        .     .        . (2,i) : numero du joint simple cree        .
  59 c .        .     .        . (3,i) : tetraedre du cote min(fammed)      .
  60 c .        .     .        . (4,i) : tetraedre du cote max(fammed)      .
  61 c . tbaux2 . es  .   4**  . Pour le i-eme joint :                      .
  62 c .        .     .        . Numeros des familles MED des volumes       .
  63 c .        .     .        . jouxtant le pentaedre/hexaedre, classes du .
  64 c .        .     .        . plus petit (1,i) au plus grand             .
  65 c .        .     .        . 0, si pas de volume voisin                 .
  66 c . tbau30 .   s .   8**  . Pour la i-eme duplication de noeud :       .
  67 c .        .     .        . (1,i) : noeud a dupliquer                  .
  68 c .        .     .        . (2,i) : arete construite sur le noeud      .
  69 c .        .     .        . (3,i) : noeud cree cote min(fammed)        .
  70 c .        .     .        . (4,i) : noeud cree cote max(fammed)        .
  71 c .        .     .        . (5,i) : numero du joint simple cree        .
  72 c .        .     .        . (6,i) : arete entrant dans le cote 1       .
  73 c .        .     .        . (7,i) : arete entrant dans le cote 2       .
  74 c .        .     .        . (8,i) : ordre de multiplicite              .
  75 c . tbau40 .   s .   6**  . Pour la i-eme duplication d'arete :        .
  76 c .        .     .        . (1,i) : arete a dupliquer                  .
  77 c .        .     .        . (2,i) : arete creee cote min(fammed)       .
  78 c .        .     .        . (3,i) : arete creee cote max(fammed)       .
  79 c .        .     .        . (4,i) : numero du joint simple cree        .
  80 c .        .     .        . (5,i) : ordre de multiplicite              .
  81 c .        .     .        . (6,i) : arete d'orientation de joint       .
  82 c . tbau31 .  s  .   2**  . Les triangles puis les quadrangles         .
  83 c .        .     .        . construits sur un noeud multiple :         .
  84 c .        .     .        . (1,i) : noeud multiple                     .
  85 c .        .     .        . (2,i) : numero du joint multiple cree      .
  86 c . tbau41 .  s  .   4**  . Les pentaedres de joint triple, puis les   .
  87 c .        .     .        . hexaedres de joint quadruple :             .
  88 c .        .     .        . (1,i) : arete multiple                     .
  89 c .        .     .        . (2,i) : numero du joint                    .
  90 c .        .     .        . Pour le i-eme pentaedre de joint triple :  .
  91 c .        .     .        . (3,i) : triangle cree cote 1er sommet      .
  92 c .        .     .        . (4,i) : triangle cree cote 2nd sommet      .
  93 c .        .     .        . Pour le i-eme hexaedre de joint quadruple :.
  94 c .        .     .        . (3,i) : quadrangle cree cote 1er sommet    .
  95 c .        .     .        . (4,i) : quadrangle cree cote 2nd sommet    .
  96 c . nbduno .  s  .   1    . nombre de duplications de noeuds           .
  97 c . nbduar .  s  .   1    . nombre de duplications d'aretes            .
  98 c . nbdutr .  s  .   1    . nombre de duplications de triangles        .
  99 c . nbnotn .  s  .   1    . nombre de noeuds total nouveau             .
 100 c . nbartn .  s  .   1    . nombre d'aretes total nouveau              .
 101 c . nbtrtn .  s  .   1    . nombre de triangles total nouveau          .
 102 c . nbqutn .  s  .   1    . nombre de quadrangles total nouveau        .
 103 c . nbtetn .  s  .   1    . nombre de tetraaedres total nouveau        .
 104 c . nbpetn .  s  .   1    . nombre de pentaedres total nouveau         .
 105 c . nbhetn .  s  .   1    . nombre d'hexaedres total nouveau           .
 106 c . nbjoit .  s  .   1    . nombre de joints triples                   .
 107 c . nbpejt .  s  .   1    . nombre de pentaedres de joints triples     .
 108 c . nbtrjt .  s  .   1    . nombre de triangles de joints triples      .
 109 c . nbjoiq .  s  .   1    . nombre de joints quadruples                .
 110 c . nbhejq .  s  .   1    . nombre d'hexaedres de joints quadruples    .
 111 c . nbqujq .  s  .   1    . nombre de quad. crees pour j. quadruples   .
 112 c . nbjp06 .  s  .   1    . nombre de joints ponctuels ordre 6         .
 113 c . nbte06 .  s  .   1    . nombre de tetr. des j. ponctuels d'ordre 6 .
 114 c . nbjp09 .  s  .   1    . nombre de joints ponctuels ordre 9         .
 115 c . nbpe09 .  s  .   1    . nombre de pent. des j. ponctuels d'ordre 9 .
 116 c . nbjp12 .  s  .   1    . nombre de joints ponctuels ordre 12        .
 117 c . nbhe12 .  s  .   1    . nombre de hexa. des j. ponctuels d'ordre 12.
 118 c . nbvojm .  s  .   1    . nombre de volumes de joints multiples      .
 119 c . tbaux5 . --- .   4**  . Pour la i-eme duplication d'arete :        .
 120 c .        .     .        . (1,i), (2,i), (3,i), (4,i)                 .
 121 c .        .     .        . numeros ordonnes des joints simples crees  .
 122 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 123 c . langue . e   .    1   . langue des messages                        .
 124 c .        .     .        . 1 : francais, 2 : anglais                  .
 125 c . codret . es  .    1   . code de retour des modules                 .
 126 c .        .     .        . 0 : pas de probleme                        .
 127 c ______________________________________________________________________
 128 c
 129 c====
 130 c 0. declarations et dimensionnement
 131 c====
 132 c
 133 c 0.1. ==> generalites
 134 c
 135       implicit none
 136       save
 137 c
 138       character*6 nompro
 139       parameter ( nompro = 'MMAG10' )
 140 c
 141 #include "nblang.h"
 142 c
 143 c 0.2. ==> communs
 144 c
 145 #include "gmenti.h"
 146 #include "envex1.h"
 147 #include "impr02.h"
 148 c
 149 #include "nombno.h"
 150 #include "nombar.h"
 151 #include "nombtr.h"
 152 #include "nombte.h"
 153 c
 154 c 0.3. ==> arguments
 155 c
 156       integer somare(2,nbarto)
 157       integer aretri(nbtrto,3)
 158       integer tritet(nbtecf,4), cotrte(nbtecf,4)
 159       integer nbjois, nbpejs
 160       integer tbaux1(4,nbpejs), tbaux2(4,*)
 161       integer tbau30(8,*), tbau40(6,*)
 162       integer tbau31(2,*), tbau41(4,*)
 163       integer tbaux5(4,*)
 164 c
 165       integer nbduno, nbduar, nbdutr
 166       integer nbnotn, nbartn, nbtrtn, nbqutn
 167       integer nbtetn, nbpetn, nbhetn
 168       integer nbjoit, nbpejt, nbtrjt
 169       integer nbjoiq, nbhejq, nbqujq
 170       integer nbjp06, nbte06
 171       integer nbjp09, nbpe09
 172       integer nbjp12, nbhe12
 173       integer nbvojm
 174       integer ptra51, ptra52, ptra53
 175 c
 176       character*8 ntra51, ntra52, ntra53
 177 c
 178       integer ulsort, langue, codret
 179 c
 180 c 0.4. ==> variables locales
 181 c
 182       integer codre1, codre2, codre3
 183       integer codre0
 184 c
 185       integer iaux, jaux
 186 #ifdef _DEBUG_HOMARD_
 187       integer kaux
 188 #endif
 189       integer indnoe, indare
 190       integer multax, multnx
 191 c
 192       integer muarmx
 193       parameter ( muarmx = 4 )
 194       integer nbarmu(muarmx)
 195 c
 196       integer munomx
 197       parameter ( munomx = 12 )
 198       integer nbnomu(munomx)
 199 c
 200       integer nbmess
 201       parameter ( nbmess = 30 )
 202       character*80 texte(nblang,nbmess)
 203 c
 204 c 0.5. ==> initialisations
 205 c ______________________________________________________________________
 206 c
 207 c====
 208 c 1. prealables
 209 c====
 210 c 1.1. ==> messages
 211 c
 212 #include "impr01.h"
 213 c
 214 #ifdef _DEBUG_HOMARD_
 215       write (ulsort,texte(langue,1)) 'Entree', nompro
 216       call dmflsh (iaux)
 217 #endif
 218 c
 219 #include "mmag01.h"
 220 c
 221 #ifdef _DEBUG_HOMARD_
 222       write (ulsort,texte(langue,12)) nbjois
 223       write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpejs
 224 #endif
 225 c
 226 c 1.2. ==> Constantes
 227 c
 228       codret = 0
 229 c
 230       nbduno = 0
 231       nbduar = 0
 232       indnoe = nbnoto
 233       indare = nbarto
 234       nbdutr = nbpejs
 235 #ifdef _DEBUG_HOMARD_
 236       write (ulsort,texte(langue,8)) mess14(langue,3,2), nbdutr
 237 #endif
 238 c
 239 c====
 240 c 2. Reperage des joints simples
 241 c====
 242 c
 243       if ( codret.eq.0 ) then
 244 c
 245       call gtdems (62)
 246 c
 247 #ifdef _DEBUG_HOMARD_
 248       write (ulsort,texte(langue,3)) 'MMAG11', nompro
 249 #endif
 250       call mmag11 ( somare,
 251      >              aretri,
 252      >              tritet, cotrte,
 253      >              nbpejs, tbaux1, tbaux2,
 254      >              tbau30, tbau40,
 255      >              nbduno, nbduar, nbdutr,
 256      >              indnoe, indare,
 257      >              ulsort, langue, codret )
 258 c
 259       call gtfims (62)
 260 c
 261       endif
 262 c
 263       if ( codret.eq.0 ) then
 264 c
 265 #ifdef _DEBUG_HOMARD_
 266       write (ulsort,texte(langue,11)) mess14(langue,3,-1),indnoe-nbnoto
 267       write (ulsort,texte(langue,11)) mess14(langue,3,1), indare-nbarto
 268       write (ulsort,texte(langue,11)) mess14(langue,3,2), 2*nbdutr
 269       write (ulsort,texte(langue,11)) mess14(langue,3,4), nbduar
 270 #endif
 271 c
 272       nbnotn = indnoe
 273       nbartn = indare
 274       nbtrtn = nbtrto + 2*nbdutr
 275       nbqutn = nbduar
 276 c
 277 #ifdef _DEBUG_HOMARD_
 278       write (ulsort,texte(langue,10)) mess14(langue,3,-1), nbnotn
 279       write (ulsort,texte(langue,10)) mess14(langue,3,1), nbartn
 280       write (ulsort,texte(langue,10)) mess14(langue,3,2), nbtrtn
 281       write (ulsort,texte(langue,10)) mess14(langue,3,4), nbqutn
 282 #endif
 283 c
 284       endif
 285 c
 286 c====
 287 c 3. Reperage des joints multiples
 288 c====
 289 c
 290       call gtdems (63)
 291 c
 292 c 3.1. ==> Recherche des aretes et des noeuds multiples
 293 c
 294       if ( codret.eq.0 ) then
 295 c
 296 #ifdef _DEBUG_HOMARD_
 297       write (ulsort,texte(langue,3)) 'MMAG12', nompro
 298 #endif
 299       call mmag12 ( muarmx, nbarmu, multax,
 300      >              munomx, nbnomu, multnx,
 301      >              nbduno, nbduar,
 302      >              tbau30, tbau40,
 303      >              tbaux5,
 304      >              ulsort, langue, codret )
 305 c
 306       endif
 307 c
 308 c 3.2. ==> Allocation
 309 c
 310       if ( codret.eq.0 ) then
 311 c
 312       jaux = 0
 313       do 32 , iaux = 4 , multnx
 314         jaux = jaux + nbnomu(iaux)
 315    32 continue
 316 c
 317       iaux = (1+2*4)*nbnomu(6)
 318       call gmalot ( ntra51, 'entier  ', iaux, ptra51, codre1 )
 319 c
 320       iaux = (1+2*5)*nbnomu(9)
 321       call gmalot ( ntra52, 'entier  ', iaux, ptra52, codre2 )
 322 c
 323       iaux = (1+2*6)*nbnomu(12)
 324       call gmalot ( ntra53, 'entier  ', iaux, ptra53, codre3 )
 325 c
 326       codre0 = min ( codre1, codre2, codre3 )
 327       codret = max ( abs(codre0), codret,
 328      >               codre1, codre2, codre3 )
 329 c
 330       endif
 331 c
 332 c 3.3. ==> Creation des mailles a partir des aretes et noeuds multiples
 333 c
 334       if ( codret.eq.0 ) then
 335 c
 336 #ifdef _DEBUG_HOMARD_
 337       write (ulsort,texte(langue,3)) 'MMAG13', nompro
 338 #endif
 339       call mmag13 ( muarmx, nbarmu, multax, multnx,
 340      >              somare,
 341      >              nbjois, tbaux2,
 342      >              nbduno, nbduar, nbtrtn, nbqutn,
 343      >              tbau30, tbau40,
 344      >              tbau31, tbau41,
 345      >              imem(ptra51), imem(ptra52), imem(ptra53),
 346      >              nbjoit, nbpejt, nbtrjt,
 347      >              nbjoiq, nbhejq, nbqujq,
 348      >              nbjp06, nbte06,
 349      >              nbjp09, nbpe09,
 350      >              nbjp12, nbhe12,
 351      >              tbaux5,
 352      >              ulsort, langue, codret )
 353 c
 354       endif
 355 cgn              nbjp06=0
 356 cgn              nbte06=0
 357 c
 358       call gtfims (63)
 359 c
 360 c====
 361 c 4. Messages
 362 c====
 363 c
 364 c 4.1. ==> Nouvelles entites
 365 c
 366       if ( codret.eq.0 ) then
 367 c
 368       nbtrtn = nbtrtn + nbtrjt
 369       nbqutn = nbqutn + nbqujq
 370       nbtetn = nbteto + nbte06
 371       nbpetn = nbpejs + nbpejt + nbpe09
 372       nbhetn = nbhejq + nbhe12
 373 c
 374       nbvojm = nbpejt + nbhejq
 375 c
 376 #ifdef _DEBUG_HOMARD_
 377       write (ulsort,texte(langue,10)) mess14(langue,3,2), nbtrtn
 378       write (ulsort,texte(langue,10)) mess14(langue,3,3), nbtetn
 379       write (ulsort,texte(langue,10)) mess14(langue,3,4), nbqutn
 380       write (ulsort,texte(langue,10)) mess14(langue,3,7), nbpetn
 381       write (ulsort,texte(langue,10)) mess14(langue,3,6), nbhetn
 382 #endif
 383 c
 384       endif
 385 c
 386 c 4.2. ==> Joints triples
 387 c
 388       if ( nbjoit.gt.0 ) then
 389 c
 390         if ( codret.eq.0 ) then
 391 c
 392         write (ulsort,texte(langue,13)) nbjoit
 393         write (ulsort,texte(langue,11)) mess14(langue,3,7), nbpejt
 394 #ifdef _DEBUG_HOMARD_
 395         write (ulsort,texte(langue,11)) mess14(langue,3,2), nbtrjt
 396 #endif
 397 c
 398 #ifdef _DEBUG_HOMARD_
 399         write (ulsort,1420)
 400         jaux = nbjois + 1
 401         kaux = nbjois + nbjoit
 402         do 42 , iaux = jaux, kaux
 403           write (ulsort,1421) iaux-nbjois,
 404      >    tbaux2(1,iaux), tbaux2(2,iaux), tbaux2(3,iaux)
 405    42   continue
 406         write (ulsort,1422)
 407 c
 408  1420   format( /,5x,41('*'),
 409      >          /,5x,'* Joint t *',3(' Joint s *'),
 410      >          /,5x,41('*'))
 411  1421   format(4x,4(' *',i8),' *')
 412  1422   format(5x,41('*'),/)
 413 #endif
 414 c
 415         endif
 416 c
 417       endif
 418 c
 419 c 4.3. ==> Joints quadruples
 420 c
 421       if ( nbjoiq.gt.0 ) then
 422 c
 423         if ( codret.eq.0 ) then
 424 c
 425         write (ulsort,texte(langue,14)) nbjoiq
 426         write (ulsort,texte(langue,11)) mess14(langue,3,6), nbhejq
 427 #ifdef _DEBUG_HOMARD_
 428         write (ulsort,texte(langue,11)) mess14(langue,3,4), nbqujq
 429 #endif
 430 c
 431 #ifdef _DEBUG_HOMARD_
 432         write (ulsort,1430)
 433         jaux = nbjois + nbjoit + 1
 434         kaux = nbjois + nbjoit + nbjoiq
 435         do 43 , iaux = jaux, kaux
 436           write (ulsort,1431) iaux-nbjois-nbjoit,
 437      >    tbaux2(1,iaux), tbaux2(2,iaux), tbaux2(3,iaux), tbaux2(4,iaux)
 438    43   continue
 439         write (ulsort,1432)
 440 c
 441  1430   format( /,5x,51('*'),
 442      >          /,5x,'* Joint q *',4(' Joint s *'),
 443      >          /,5x,51('*'))
 444  1431   format(4x,5(' *',i8),' *')
 445  1432   format(5x,51('*'),/)
 446 #endif
 447 c
 448         endif
 449 c
 450       endif
 451 c
 452 c 4.4. ==> Joints ponctuels
 453 c
 454       if ( nbjp06.gt.0 ) then
 455 c
 456         if ( codret.eq.0 ) then
 457 c
 458         write (ulsort,texte(langue,21)) 6, nbjp06
 459         write (ulsort,texte(langue,11)) mess14(langue,3,3), nbte06
 460 c
 461         endif
 462 c
 463       endif
 464 c
 465       if ( nbjp09.gt.0 ) then
 466 c
 467         if ( codret.eq.0 ) then
 468 c
 469         write (ulsort,texte(langue,21)) 9, nbjp09
 470         write (ulsort,texte(langue,11)) mess14(langue,3,7), nbpe09
 471 c
 472         endif
 473 c
 474       endif
 475 c
 476       if ( nbjp12.gt.0 ) then
 477 c
 478         if ( codret.eq.0 ) then
 479 c
 480         write (ulsort,texte(langue,21)) 12, nbjp12
 481         write (ulsort,texte(langue,11)) mess14(langue,3,6), nbhe12
 482 c
 483         endif
 484 c
 485       endif
 486 cc
 487 c====
 488 c 5. la fin
 489 c====
 490 c
 491       if ( codret.ne.0 ) then
 492 c
 493 #include "envex2.h"
 494 c
 495       write (ulsort,texte(langue,1)) 'Sortie', nompro
 496       write (ulsort,texte(langue,2)) codret
 497 c
 498       endif
 499 c
 500 #ifdef _DEBUG_HOMARD_
 501       write (ulsort,texte(langue,1)) 'Sortie', nompro
 502       call dmflsh (iaux)
 503 #endif
 504 c
 505       end