src/tool/Modification/mmagr6.F

   1       subroutine mmagr6 ( nbduno, nbduar, nbdutr,
   2      >                    tbaux1, tbau30, tbau40,
   3      >                    tbaux2, tbaux5, tbaux6,
   4      >                    coonoe, famnoe,
   5      >                    somare, famare,
   6      >                    aretri, famtri, arequa,
   7      >                    tritet, facpen,
   8      >                    anctri, noutri,
   9      >                    ancare, nouare,
  10      >                    ancnoe, nounoe,
  11      >                    nbtrtn, nbartn, nbnotn,
  12      >                    ulsort, langue, codret )
  13 c ______________________________________________________________________
  14 c
  15 c                             H O M A R D
  16 c
  17 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  18 c
  19 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  20 c aupres des huissiers de justice Simart et Lavoir a Clamart
  21 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  22 c aupres des huissiers de justice
  23 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  24 c
  25 c    HOMARD est une marque deposee d'Electricite de France
  26 c
  27 c Copyright EDF 1996
  28 c Copyright EDF 1998
  29 c Copyright EDF 2002
  30 c Copyright EDF 2020
  31 c ______________________________________________________________________
  32 c
  33 c    Modification de Maillage - AGRegat - phase 6
  34 c    -               -          ---             -
  35 c    Suppression des noeuds, aretes et triangles dupliques
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . nbduno . e   .   1    . nombre de duplications de noeuds           .
  41 c . nbduar . e   .   1    . nombre de duplications d'aretes            .
  42 c . nbdutr . e   .   1    . nombre de duplications de triangles        .
  43 c . tbaux1 . e   .4*nbpejs. Pour le i-eme pentaedre de joint simple :  .
  44 c .        .     .        . (1,i) : numero du triangle a dupliquer     .
  45 c .        .     .        . (2,i) : numero du joint simple cree        .
  46 c .        .     .        . (3,i) : tetraedre du cote min(fammed)      .
  47 c .        .     .        . (4,i) : tetraedre du cote max(fammed)      .
  48 c . tbau30 . e   .8*nbduno. Pour la i-eme duplication de noeud :       .
  49 c .        .     .        . (1,i) : noeud a dupliquer                  .
  50 c .        .     .        . (2,i) : arete construite sur le noeud      .
  51 c .        .     .        . (3,i) : noeud cree cote min(fammed)        .
  52 c .        .     .        . (4,i) : noeud cree cote max(fammed)        .
  53 c .        .     .        . (5,i) : numero du joint simple cree        .
  54 c .        .     .        . (6,i) : arete entrant dans le cote 1       .
  55 c .        .     .        . (7,i) : arete entrant dans le cote 2       .
  56 c .        .     .        . (8,i) : ordre de multiplicite              .
  57 c . tbau40 . e   .6*nbduar. Pour la i-eme duplication d'arete :        .
  58 c .        .     .        . (1,i) : arete a dupliquer                  .
  59 c .        .     .        . (2,i) : arete creee cote min(fammed)       .
  60 c .        .     .        . (3,i) : arete creee cote max(fammed)       .
  61 c .        .     .        . (4,i) : numero du joint simple cree        .
  62 c .        .     .        . (5,i) : ordre de multiplicite              .
  63 c .        .     .        . (6,i) : arete d'orientation de joint       .
  64 c . tbaux2 . --  . nbnoto . auxiliaire                                 .
  65 c . tbaux5 . --  . nbarto . auxiliaire                                 .
  66 c . tbaux6 . --  . nbtrto . auxiliaire                                 .
  67 c . coonoe . es  .nbnoto*3. coordonnees des noeuds                     .
  68 c . famnoe . es  . nbnoto . famille des noeuds                         .
  69 c . somare . es  .2*nbarto. numeros des extremites d'arete             .
  70 c . famare . es  . nbarto . famille des aretes                         .
  71 c . aretri . es  .nbtrto*3. numeros des 3 aretes des triangles         .
  72 c . famtri . es  . nbtrto . famille des triangles                      .
  73 c . arequa . es  .nbquto*4. numeros des 4 aretes des quadrangle        .
  74 c . tritet . e/s .nbtecf*4. numeros des 4 triangles des tetraedres     .
  75 c . facpen . e/s .nbpecf*5. numeros des 5 faces des pentaedres         .
  76 c . nbnotn .  s  .   1    . nombre de noeuds total nouveau             .
  77 c . nbartn .  s  .   1    . nombre d'aretes total nouveau              .
  78 c . nbtrtn .  s  .   1    . nombre de triangles total nouveau          .
  79 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  80 c . langue . e   .    1   . langue des messages                        .
  81 c .        .     .        . 1 : francais, 2 : anglais                  .
  82 c . codret . es  .    1   . code de retour des modules                 .
  83 c .        .     .        . 0 : pas de probleme                        .
  84 c ______________________________________________________________________
  85 c
  86 c====
  87 c 0. declarations et dimensionnement
  88 c====
  89 c
  90 c 0.1. ==> generalites
  91 c
  92       implicit none
  93       save
  94 c
  95       character*6 nompro
  96       parameter ( nompro = 'MMAGR6' )
  97 c
  98 #include "nblang.h"
  99 c
 100 c 0.2. ==> communs
 101 c
 102 #include "envex1.h"
 103 c
 104 #include "coftex.h"
 105 #include "envca1.h"
 106 #include "nombno.h"
 107 #include "nombar.h"
 108 #include "nombtr.h"
 109 #include "nombqu.h"
 110 #include "nombte.h"
 111 #include "nombpe.h"
 112 #include "impr02.h"
 113 c
 114 c 0.3. ==> arguments
 115 c
 116       integer nbduno, nbduar, nbdutr
 117       integer tbaux1(4,nbdutr), tbau30(8,nbduno), tbau40(6,nbduar)
 118       integer tbaux2(nbnoto), tbaux5(nbarto), tbaux6(nbtrto)
 119       integer famnoe(nbnoto)
 120       integer somare(2,nbarto), famare(nbarto)
 121       integer aretri(nbtrto,3), famtri(nbtrto)
 122       integer arequa(nbquto,4)
 123       integer tritet(nbtecf,4)
 124       integer facpen(nbpecf,5)
 125       integer anctri(nbtrto), noutri(0:nbtrto)
 126       integer ancare(nbarto), nouare(0:nbarto)
 127       integer ancnoe(nbnoto), nounoe(0:nbnoto)
 128       integer nbtrtn, nbartn, nbnotn
 129 c
 130       double precision coonoe(nbnoto,sdim)
 131 c
 132       integer ulsort, langue, codret
 133 c
 134 c 0.4. ==> variables locales
 135 c
 136       integer iaux, jaux
 137       integer lepent, letetr, letria, lequad, larete
 138       integer lenoeu
 139       integer nbarmu, nbnomu
 140 c
 141       integer nbmess
 142       parameter ( nbmess = 40 )
 143       character*80 texte(nblang,nbmess)
 144 c
 145 c 0.5. ==> initialisations
 146 c ______________________________________________________________________
 147 c
 148 c====
 149 c 1. initialisations
 150 c====
 151 c 1.1. ==> messages
 152 c
 153 #include "impr01.h"
 154 c
 155 #ifdef _DEBUG_HOMARD_
 156       write (ulsort,texte(langue,1)) 'Entree', nompro
 157       call dmflsh (iaux)
 158 #endif
 159 c
 160 #include "mmag01.h"
 161 c
 162       texte(1,31) = '(a,'' Traitement du '',a,i8,'', ordre'',i3)'
 163 c
 164       texte(2,31) = '(a,'' Treatment of the '',a,i8,'', order'',i3)'
 165 c
 166 #ifdef _DEBUG_HOMARD_
 167       write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno
 168       write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar
 169       write (ulsort,texte(langue,8)) mess14(langue,3,2), nbdutr
 170 #endif
 171 c
 172       codret = 0
 173 c
 174 c====
 175 c 2. Reperages
 176 c====
 177 c 2.1. ==> Triangles
 178 c
 179       do 211 , iaux = 1 , nbtrto
 180         tbaux6(iaux) = 0
 181   211 continue
 182 c
 183       do 212 , iaux = 1 , nbdutr
 184         letria = tbaux1(1,iaux)
 185         tbaux6(letria) = 1
 186 #ifdef _DEBUG_HOMARD_
 187       write (ulsort,texte(langue,31)) '.', mess14(langue,1,2),
 188      >                               letria, tbaux6(letria)
 189 #endif
 190   212 continue
 191 c
 192 c 2.2. ==> Aretes
 193 c
 194       do 221 , iaux = 1 , nbarto
 195         tbaux5(iaux) = 0
 196   221 continue
 197 c
 198       nbarmu = 0
 199       do 222 , iaux = 1 , nbduar
 200         larete = tbau40(1,iaux)
 201         if ( tbaux5(larete).ge.1 ) then
 202           nbarmu = nbarmu + 1
 203 cgn              write (ulsort,*)'LARETE',larete
 204         endif
 205         tbaux5(larete) = tbaux5(larete) + 1
 206 #ifdef _DEBUG_HOMARD_
 207       write (ulsort,texte(langue,31)) '.', mess14(langue,1,1),
 208      >                               larete, tbaux5(larete)
 209 #endif
 210   222 continue
 211 c
 212 c 2.3. ==> Noeuds
 213 c
 214       do 231 , iaux = 1 , nbnoto
 215         tbaux2(iaux) = 0
 216   231 continue
 217 c
 218       nbnomu = 0
 219       do 232 , iaux = 1 , nbduno
 220         lenoeu = tbau30(1,iaux)
 221         if ( tbaux2(lenoeu).ge.1 ) then
 222           nbnomu = nbnomu + 1
 223 cgn              write (ulsort,*)'LENOEU',lenoeu
 224         endif
 225         tbaux2(lenoeu) = tbaux2(lenoeu) +1
 226 #ifdef _DEBUG_HOMARD_
 227       write (ulsort,texte(langue,31)) '.', mess14(langue,1,-1),
 228      >                               lenoeu, tbaux2(lenoeu)
 229 #endif
 230   232 continue
 231 c
 232 c====
 233 c 3. suppression des entites
 234 c====
 235 c 3.1. ==> suppression des triangles
 236 #ifdef _DEBUG_HOMARD_
 237       write (ulsort,*) '3.1. suppression tria ; codret =', codret
 238 #endif
 239 c
 240       if ( codret.eq.0 ) then
 241 c
 242       nbtrtn = 0
 243       noutri(0) = 0
 244 c
 245       do 31 , letria = 1 , nbtrto
 246 c
 247         if ( tbaux6(letria).gt.0 ) then
 248 c
 249           noutri(letria) = 0
 250 c
 251         else
 252 c
 253           nbtrtn = nbtrtn + 1
 254           anctri(nbtrtn) = letria
 255           noutri(letria) = nbtrtn
 256 c
 257         endif
 258 c
 259    31 continue
 260 c
 261       if ( nbtrtn+nbdutr.ne.nbtrto ) then
 262         codret = 31
 263       endif
 264 cgn      print*,nbtrtn,nbdutr,nbtrto
 265 c
 266       endif
 267 c
 268 c 3.2. ==> suppression des aretes
 269 #ifdef _DEBUG_HOMARD_
 270       write (ulsort,*) '3.2. suppression aret ; codret =', codret
 271 #endif
 272 c
 273       if ( codret.eq.0 ) then
 274 c
 275       nbartn = 0
 276       nouare(0) = 0
 277 c
 278       do 32 , larete = 1 , nbarto
 279 c
 280         if ( tbaux5(larete).gt.0 ) then
 281 c
 282           nouare(larete) = 0
 283 c
 284         else
 285 c
 286           nbartn = nbartn + 1
 287           ancare(nbartn) = larete
 288           nouare(larete) = nbartn
 289 c
 290         endif
 291 cgn        write (ulsort,*) larete,tbaux5(larete),nbartn
 292 c
 293    32 continue
 294 c
 295       if ( nbartn+nbduar-nbarmu.ne.nbarto ) then
 296         codret = 32
 297         write (ulsort,*) nbartn,nbduar,nbarmu,nbarto
 298       endif
 299 cgn      write (ulsort,*) nbartn,nbduar,nbarmu,nbarto
 300 c
 301       endif
 302 c
 303 c 3.3. ==> suppression des noeuds
 304 #ifdef _DEBUG_HOMARD_
 305       write (ulsort,*) '3.3. suppression noeuds ; codret =', codret
 306 #endif
 307 c
 308       if ( codret.eq.0 ) then
 309 c
 310       nbnotn = 0
 311       nounoe(0) = 0
 312 c
 313       do 33 , lenoeu = 1 , nbnoto
 314 c
 315         if ( tbaux2(lenoeu).gt.0 ) then
 316 c
 317           nounoe(lenoeu) = 0
 318 c
 319         else
 320 c
 321           nbnotn = nbnotn + 1
 322           ancnoe(nbnotn) = lenoeu
 323           nounoe(lenoeu) = nbnotn
 324 c
 325         endif
 326 c
 327    33 continue
 328 c
 329       if ( nbnotn+nbduno-nbnomu.ne.nbnoto ) then
 330         codret = 33
 331         write (ulsort,*) nbnotn,nbduno,nbnomu,nbnoto
 332       endif
 333 cgn      write (ulsort,*) nbnotn,nbduno,nbnomu,nbnoto
 334 c
 335       endif
 336 c
 337 c====
 338 c 4. compactage des numerotations
 339 c====
 340 c 4.1. ==> compactage des triangles
 341 #ifdef _DEBUG_HOMARD_
 342       write (ulsort,*) '4.1 compactage tria ; codret =', codret
 343 #endif
 344 c
 345       if ( codret.eq.0 ) then
 346 c
 347 c 4.1.1. ==> Impact sur la definition des tetraedres
 348 c
 349       do 411 , letetr = 1 , nbteto
 350 c
 351         do 4111 , iaux = 1 , 4
 352           tritet(letetr,iaux) = noutri(tritet(letetr,iaux))
 353  4111   continue
 354 c
 355   411 continue
 356 c
 357 c 4.1.2. ==> Impact sur la definition des pentaedres
 358 c
 359       do 412 , lepent = 1 , nbpeto
 360 c
 361         do 4121 , iaux = 1 , 2
 362           facpen(lepent,iaux) = noutri(facpen(lepent,iaux))
 363  4121   continue
 364 c
 365   412 continue
 366 c
 367 c 4.1.3. ==> Dans les tableaux des triangles, on ne traite pas :
 368 c            hettri : toujours = 0
 369 c            mertri : toujours = 0
 370 c            filtri : toujours = 0
 371 c
 372       do 413 , letria = 1 , nbtrtn
 373 c
 374         do 4131, iaux = 1 , 3
 375           aretri(letria,iaux) = aretri(anctri(letria),iaux)
 376  4131   continue
 377 c
 378         famtri(letria) = famtri(anctri(letria))
 379 c
 380   413 continue
 381 c
 382       endif
 383 c
 384 c 4.2. ==> compactage des aretes
 385 #ifdef _DEBUG_HOMARD_
 386       write (ulsort,*) '4.2 compactage aret ; codret =', codret
 387 #endif
 388 c
 389       if ( codret.eq.0 ) then
 390 c
 391 c 4.2.1. ==> Impact sur la definition des triangles
 392 c
 393       do 421 , letria = 1 , nbtrtn
 394 c
 395 cgn      write (ulsort,*) (nouare(aretri(letria,iaux)), iaux = 1 , 3)
 396         do 4211, iaux = 1 , 3
 397           aretri(letria,iaux) = nouare(aretri(letria,iaux))
 398  4211   continue
 399 c
 400   421 continue
 401 c
 402 c 4.2.2. ==> Impact sur la definition des quadrangles
 403 c
 404       do 422 , lequad = 1 , nbquto
 405 c
 406 cgn      write (ulsort,*) lequad,(arequa(lequad,iaux), iaux = 1,4)
 407 cgn      write (ulsort,*) lequad,(nouare(arequa(lequad,iaux)), iaux = 1,4)
 408         do 4221, iaux = 1 , 4
 409           arequa(lequad,iaux) = nouare(arequa(lequad,iaux))
 410  4221   continue
 411 c
 412   422 continue
 413 c
 414 c 4.2.3. ==> Dans les tableaux des aretes, on ne traite pas :
 415 c            hetare : toujours = 0
 416 c            merare : toujours = 0
 417 c            filare : toujours = 0
 418 c
 419       do 423 , larete = 1 , nbartn
 420 c
 421 cgn      write (ulsort,*) larete
 422 cgn      write (ulsort,*) ancare(larete)
 423         somare(1,larete) = somare(1,ancare(larete))
 424         somare(2,larete) = somare(2,ancare(larete))
 425 c
 426         famare(larete) = famare(ancare(larete))
 427 c
 428   423 continue
 429 c
 430       endif
 431 c
 432 c 4.3 ==> compactage des noeuds
 433 #ifdef _DEBUG_HOMARD_
 434       write (ulsort,*) '4.3. compactage noeuds ; codret =', codret
 435 #endif
 436 c
 437 c 4.3.1. ==> Impact sur la definition des aretes
 438 c
 439       if ( codret.eq.0 ) then
 440 c
 441       do 431 , larete = 1 , nbartn
 442 c
 443 #ifdef _DEBUG_HOMARD_
 444       write (ulsort,texte(langue,4)) ' ', mess14(langue,1,1), larete
 445 #endif
 446         iaux = nounoe(somare(1,larete))
 447         jaux = nounoe(somare(2,larete))
 448         somare(1,larete) = min(iaux,jaux)
 449         somare(2,larete) = max(iaux,jaux)
 450 c
 451   431 continue
 452 c
 453 c 4.3.2. ==> Dans les tableaux des noeuds, on ne traite pas :
 454 c            hetnoe : toujours = 1
 455 c            arenoe : toujours = 0
 456 c
 457       do 432 , lenoeu = 1 , nbnotn
 458 #ifdef _DEBUG_HOMARD_
 459       write (ulsort,texte(langue,4)) ' ', mess14(langue,1,-1), lenoeu
 460 #endif
 461 c
 462         if ( ancnoe(lenoeu).ne.lenoeu ) then
 463 c
 464           do 4321, iaux = 1 , sdim
 465             coonoe(lenoeu,iaux) = coonoe(ancnoe(lenoeu),iaux)
 466  4321     continue
 467 c
 468         famnoe(lenoeu) = famnoe(ancnoe(lenoeu))
 469 c
 470         endif
 471 c
 472   432 continue
 473 c
 474       endif
 475 c
 476 c====
 477 c 5. la fin
 478 c====
 479 c
 480       if ( codret.ne.0 ) then
 481 c
 482 #include "envex2.h"
 483 c
 484       write (ulsort,texte(langue,1)) 'Sortie', nompro
 485       write (ulsort,texte(langue,2)) codret
 486 c
 487       endif
 488 c
 489 #ifdef _DEBUG_HOMARD_
 490       write (ulsort,texte(langue,1)) 'Sortie', nompro
 491       call dmflsh (iaux)
 492 #endif
 493 c
 494       end