src/tool/Modification/mmag11.F

   1       subroutine mmag11 ( somare,
   2      >                    aretri,
   3      >                    tritet, cotrte,
   4      >                    nbpejs, tbaux1, tbaux2,
   5      >                    tbau30, tbau40,
   6      >                    nbduno, nbduar, nbdutr,
   7      >                    indnoe, indare,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    Modification de Maillage - AGregat - phase 1.1
  30 c    -               -          --              - -
  31 c    Connaissant le nombre et les caracteristiques des pentaedres
  32 c    a creer pour les joints simples :
  33 c    . Liste des duplications de noeuds avec pour chacune d'elles :
  34 c      - numero du noeud a dupliquer
  35 c      - numero de l'arete entre les noeuds doubles
  36 c      - numero des 2 noeuds doubles a creer
  37 c      - numero du joint simple exigeant la duplication
  38 c    . Liste des duplications d'aretes avec pour chacune d'elles :
  39 c      - numero de l'arete entre les noeuds doubles
  40 c      - numero des 2 aretes doubles a creer
  41 c      - numero du joint simple exigeant la duplication
  42 c    . Decompte du nombre de duplications de noeuds, d'aretes et
  43 c      de triangles
  44 c    . Numero du dernier noeud cree
  45 c    . Numero de la derniere arete creee
  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 . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  53 c . cotrte . e   .nbtecf*4. codes des 4 triangles des tetraedres       .
  54 c . nbpejs . e   .   1    . nombre de pentaedres de joints simples     .
  55 c . tbaux1 . e   .4*nbpejs. Pour le i-eme pentaedre de joint simple :  .
  56 c .        .     .        . (1,i) : numero du triangle a dupliquer     .
  57 c .        .     .        . (2,i) : numero du joint simple cree        .
  58 c .        .     .        . (3,i) : tetraedre du cote min(fammed)      .
  59 c .        .     .        . (4,i) : tetraedre du cote max(fammed)      .
  60 c . tbaux2 . e   .   4**  . Pour le i-eme joint :                      .
  61 c .        .     .        . Numeros des familles MED des volumes       .
  62 c .        .     .        . jouxtant le pentaedre/hexaedre, classes du .
  63 c .        .     .        . plus petit (1,i) au plus grand             .
  64 c .        .     .        . 0, si pas de volume voisin                 .
  65 c . tbau30 .   s .   8**  . Pour la i-eme duplication de noeud :       .
  66 c .        .     .        . (1,i) : noeud a dupliquer                  .
  67 c .        .     .        . (2,i) : arete construite sur le noeud      .
  68 c .        .     .        . (3,i) : noeud cree cote min(fammed)        .
  69 c .        .     .        . (4,i) : noeud cree cote max(fammed)        .
  70 c .        .     .        . (5,i) : numero du joint simple cree        .
  71 c .        .     .        . (6,i) : arete entrant dans le cote 1       .
  72 c .        .     .        . (7,i) : arete entrant dans le cote 2       .
  73 c .        .     .        . (8,i) : ordre de multiplicite              .
  74 c . tbau40 .   s .   6**  . Pour la i-eme duplication d'arete :        .
  75 c .        .     .        . (1,i) : arete a dupliquer                  .
  76 c .        .     .        . (2,i) : arete creee cote min(fammed)       .
  77 c .        .     .        . (3,i) : arete creee cote max(fammed)       .
  78 c .        .     .        . (4,i) : numero du joint simple cree        .
  79 c .        .     .        . (5,i) : ordre de multiplicite              .
  80 c .        .     .        . (6,i) : arete d'orientation de joint       .
  81 c . nbduno .  s  .   1    . nombre de duplications de noeuds           .
  82 c . nbduar .  s  .   1    . nombre de duplications d'aretes            .
  83 c . nbdutr .  s  .   1    . nombre de duplications de triangles        .
  84 c . indnoe . es  .   1    . dernier noeud a creer                      .
  85 c . indare . es  .   1    . derniere arete a creer                     .
  86 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  87 c . langue . e   .    1   . langue des messages                        .
  88 c .        .     .        . 1 : francais, 2 : anglais                  .
  89 c . codret . es  .    1   . code de retour des modules                 .
  90 c .        .     .        . 0 : pas de probleme                        .
  91 c ______________________________________________________________________
  92 c
  93 c====
  94 c 0. declarations et dimensionnement
  95 c====
  96 c
  97 c 0.1. ==> generalites
  98 c
  99       implicit none
 100       save
 101 c
 102       character*6 nompro
 103       parameter ( nompro = 'MMAG11' )
 104 c
 105 #include "nblang.h"
 106 c
 107 c 0.2. ==> communs
 108 c
 109 #include "envex1.h"
 110 #include "impr02.h"
 111 c
 112 #include "nombar.h"
 113 #include "nombtr.h"
 114 #include "nombte.h"
 115 c
 116 c 0.3. ==> arguments
 117 c
 118       integer somare(2,nbarto)
 119       integer aretri(nbtrto,3)
 120       integer tritet(nbtecf,4), cotrte(nbtecf,4)
 121       integer nbpejs
 122       integer tbaux1(4,nbpejs), tbaux2(4,*)
 123       integer tbau30(8,*), tbau40(6,*)
 124 c
 125       integer nbduno, nbduar, nbdutr
 126       integer indnoe, indare
 127 c
 128       integer ulsort, langue, codret
 129 c
 130 c 0.4. ==> variables locales
 131 c
 132       integer iaux, jaux, kaux, laux
 133       integer letria
 134       integer letetr, listar(6)
 135       integer laret0(2), laret1(2)
 136       integer lenoe0(2)
 137       integer nujois, nujoi0
 138       integer fammed(2)
 139       integer som1, arejnt
 140 c
 141       integer are(3), som(3)
 142 c
 143       integer nbmess
 144       parameter ( nbmess = 40 )
 145       character*80 texte(nblang,nbmess)
 146 c
 147 c 0.5. ==> initialisations
 148 c ______________________________________________________________________
 149 c
 150 c====
 151 c 1. prealables
 152 c====
 153 c 1.1. ==> messages
 154 c
 155 #include "impr01.h"
 156 c
 157 #ifdef _DEBUG_HOMARD_
 158       write (ulsort,texte(langue,1)) 'Entree', nompro
 159       call dmflsh (iaux)
 160 #endif
 161 c
 162 #include "mmag01.h"
 163 #include "impr03.h"
 164 c
 165       texte(1,31) = '(''   ==> '',a,''en lien :'',2i8)'
 166 c
 167       texte(2,31) = '(''   ==> connected '',a,'':'',2i8)'
 168 c
 169 #ifdef _DEBUG_HOMARD_
 170       write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpejs
 171 #endif
 172 c
 173 c 1.2. ==> Constantes
 174 c
 175       codret = 0
 176 c
 177       nbduno = 0
 178       nbduar = 0
 179       nbdutr = nbpejs
 180 #ifdef _DEBUG_HOMARD_
 181       write (ulsort,texte(langue,8)) mess14(langue,3,2), nbdutr
 182 #endif
 183 c
 184 c====
 185 c 2. Parcours des pentaedres a creer pour noter les aretes a dupliquer
 186 c====
 187 #ifdef _DEBUG_HOMARD_
 188       write (ulsort,texte(langue,5)) mess14(langue,3,7)//' - ar dupl'
 189 #endif
 190 c
 191       if ( codret.eq.0 ) then
 192 c
 193       do 2 , iaux = 1 , nbpejs
 194 c
 195         letria = tbaux1(1,iaux)
 196         nujois = tbaux1(2,iaux)
 197 c
 198 #ifdef _DEBUG_HOMARD_
 199       write (ulsort,texte(langue,4)) '. ', mess14(langue,1,2), letria
 200 #endif
 201 c
 202         do 21 , jaux = 1 , 3
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,texte(langue,4)) '.. ',mess14(langue,1,1),
 206      >                               aretri(letria,jaux)
 207 #endif
 208 c
 209 c 2.1.1. ==> Si l'arete a deja ete dupliquee pour ce joint, on
 210 c            passe a la suite
 211 c
 212           do 211  , kaux = 1 , nbduar
 213 c
 214             if ( tbau40(1,kaux).eq.aretri(letria,jaux) .and.
 215      >           tbau40(4,kaux).eq.nujois ) then
 216               goto 21
 217             endif
 218 c
 219   211     continue
 220 c
 221 c 2.1.2. ==> L'arete est a dupliquer.
 222 c            On repere si elle l'a deja ete pour un des cotes.
 223 c
 224 #ifdef _DEBUG_HOMARD_
 225       write (ulsort,texte(langue,9)) mess14(langue,1,1),
 226      >                               aretri(letria,jaux)
 227 #endif
 228 c
 229           fammed(1) = tbaux2(1,nujois)
 230           fammed(2) = tbaux2(2,nujois)
 231 cgn          write(ulsort,*) fammed
 232           do 212  , laux = 1 , 2
 233             do 2121  , kaux = 1 , nbduar
 234 cgn            write(ulsort,*) kaux, tbau40(1,kaux),tbau40(4,kaux)
 235               if ( tbau40(1,kaux).eq.aretri(letria,jaux) ) then
 236                 nujoi0 = tbau40(4,kaux)
 237                 if ( tbaux2(1,nujoi0).eq.fammed(laux) ) then
 238                   laret0(laux) = tbau40(2,kaux)
 239                   goto 212
 240                 elseif ( tbaux2(2,nujoi0).eq.fammed(laux) ) then
 241                   laret0(laux) = tbau40(3,kaux)
 242                   goto 212
 243                 endif
 244               endif
 245  2121       continue
 246             indare = indare + 1
 247             laret0(laux) = indare
 248   212     continue
 249 c
 250 c 2.1.3. ==> Le triangle est a dupliquer pour le joint en cours.
 251 c            L'arete dupliquee est tbau40(1,kaux). On cherche l'autre
 252 c            arete du triangle dont une extremite est le point de depart
 253 c            de cette arete dupliquee. Cela servira a orienter les
 254 c            joints multiples.
 255 c
 256           som1 = somare(1,aretri(letria,jaux))
 257           do 213 , kaux = 1 ,3
 258             if ( kaux.ne.jaux ) then
 259               if ( som1.eq.somare(1,aretri(letria,kaux)) .or.
 260      >             som1.eq.somare(2,aretri(letria,kaux)) ) then
 261                 arejnt = aretri(letria,kaux)
 262               endif
 263             endif
 264   213     continue
 265 c
 266 c 2.1.4. ==> Enregistrement
 267 c
 268 #ifdef _DEBUG_HOMARD_
 269       write (ulsort,texte(langue,31)) mess14(langue,3,1), laret0
 270 #endif
 271           nbduar = nbduar + 1
 272           tbau40(1,nbduar) = aretri(letria,jaux)
 273           tbau40(2,nbduar) = laret0(1)
 274           tbau40(3,nbduar) = laret0(2)
 275           tbau40(4,nbduar) = nujois
 276           tbau40(6,nbduar) = arejnt
 277 c
 278    21   continue
 279 c
 280     2 continue
 281 c
 282 #ifdef _DEBUG_HOMARD_
 283       write (ulsort,texte(langue,8)) mess14(langue,3,1), nbduar
 284       write (ulsort,texte(langue,7)) mess14(langue,3,4), nbduar
 285 #endif
 286 c
 287       endif
 288 c
 289 c====
 290 c 3. Parcours des pentaedres a creer pour noter les aretes a creer
 291 c    Remarque : on le fait en deux fois pour gerer les numerotations
 292 c               des aretes de manieres independantes : d'abord celles
 293 c               issues de duplication, ensuite celles issues de
 294 c               duplications de noeuds
 295 c====
 296 #ifdef _DEBUG_HOMARD_
 297       write (ulsort,texte(langue,5)) mess14(langue,3,7)//' - ar crea'
 298 #endif
 299 c
 300       if ( codret.eq.0 ) then
 301 c
 302       do 3 , iaux = 1 , nbpejs
 303 c
 304         letria = tbaux1(1,iaux)
 305         nujois = tbaux1(2,iaux)
 306 c
 307 #ifdef _DEBUG_HOMARD_
 308       write (ulsort,texte(langue,4)) '. ', mess14(langue,1,2), letria
 309 #endif
 310 c
 311 c 3.1. ==> Aretes et les sommets
 312 c
 313         are(1) = aretri(letria,1)
 314         are(2) = aretri(letria,2)
 315         are(3) = aretri(letria,3)
 316 c
 317         call utsotr ( somare, are(1), are(2), are(3),
 318      >                som(1), som(2), som(3) )
 319 c
 320 c 3.2. ==> Les noeuds
 321 c
 322         do 32  , jaux = 1 , 3
 323 c
 324 #ifdef _DEBUG_HOMARD_
 325       write (ulsort,texte(langue,4)) '..',mess14(langue,1,-1),som(jaux)
 326 #endif
 327 c
 328 c 3.2.1. ==> Si le noeud a deja ete duplique pour ce joint, on
 329 c            passe a la suite
 330 c
 331           do 321  , kaux = 1 , nbduno
 332 c
 333             if ( tbau30(1,kaux).eq.som(jaux) .and.
 334      >           tbau30(5,kaux).eq.nujois ) then
 335 cgn              write(ulsort,*) '.... noeud deja duplique'
 336               goto 32
 337             endif
 338 c
 339   321   continue
 340 c
 341 c 3.2.2. ==> Le noeud est a dupliquer.
 342 c            On repere si il l'a deja ete pour un des cotes.
 343 c
 344 #ifdef _DEBUG_HOMARD_
 345       write (ulsort,texte(langue,9)) mess14(langue,1,-1), som(jaux)
 346 #endif
 347           fammed(1) = tbaux2(1,nujois)
 348           fammed(2) = tbaux2(2,nujois)
 349 cgn          write(ulsort,*) 'fammed des 2 cotes', fammed
 350           do 322 , laux = 1 , 2
 351             do 3221 , kaux = 1 , nbduno
 352 cgn              write(ulsort,*) 'Duplication nro', kaux
 353 cgn      write(ulsort,*)'no dup', tbau30(1,kaux), ', j simp',tbau30(5,kaux)
 354               if ( tbau30(1,kaux).eq.som(jaux) ) then
 355                 nujoi0 = tbau30(5,kaux)
 356 cgn              write(ulsort,*) 'Joint nro', nujoi0
 357 cgn      write(ulsort,*) 'avec fammed',tbaux2(1,nujoi0),tbaux2(2,nujoi0)
 358                 if ( tbaux2(1,nujoi0).eq.fammed(laux) ) then
 359                   lenoe0(laux) = tbau30(3,kaux)
 360                   goto 322
 361                 elseif ( tbaux2(2,nujoi0).eq.fammed(laux) ) then
 362                   lenoe0(laux) = tbau30(4,kaux)
 363                   goto 322
 364                 endif
 365               endif
 366  3221       continue
 367             indnoe = indnoe + 1
 368             lenoe0(laux) = indnoe
 369   322     continue
 370 c
 371 c 3.2.3. ==> Reperage de l'arete partant du noeud vers le volume
 372 c
 373           do 323 , kaux = 1 , 2
 374 c
 375             letetr = tbaux1(2+kaux,iaux)
 376             call utarte ( letetr,
 377      >                    nbtrto, nbtecf,
 378      >                    aretri, tritet, cotrte,
 379      >                    listar )
 380 cgn            write(ulsort,90002) mess14(langue,4,1)//'du noeud', listar
 381 c
 382             do 3231 , laux = 1 , 6
 383 c
 384               if ( listar(laux).ne.are(1) .and.
 385      >             listar(laux).ne.are(2) .and.
 386      >             listar(laux).ne.are(3) ) then
 387 cgn             write(ulsort,90002) mess14(langue,2,1), listar(laux)
 388                if ( somare(1,listar(laux)).eq.som(jaux) ) then
 389                  laret1(kaux) = listar(laux)
 390                elseif ( somare(2,listar(laux)).eq.som(jaux) ) then
 391                  laret1(kaux) = -listar(laux)
 392                endif
 393              endif
 394 c
 395  3231      continue
 396 c
 397   323   continue
 398 c
 399 c 3.2.4. ==> Enregistrement
 400 c
 401 #ifdef _DEBUG_HOMARD_
 402       write (ulsort,texte(langue,31)) mess14(langue,3,-1), lenoe0
 403       write (ulsort,texte(langue,31)) mess14(langue,1,1), indare+1
 404 #endif
 405           indare = indare + 1
 406           nbduno = nbduno + 1
 407           tbau30(1,nbduno) = som(jaux)
 408           tbau30(2,nbduno) = indare
 409           tbau30(3,nbduno) = lenoe0(1)
 410           tbau30(4,nbduno) = lenoe0(2)
 411           tbau30(5,nbduno) = nujois
 412           tbau30(6,nbduno) = laret1(1)
 413           tbau30(7,nbduno) = laret1(2)
 414 c
 415    32   continue
 416 c
 417     3 continue
 418 c
 419 #ifdef _DEBUG_HOMARD_
 420       write (ulsort,texte(langue,8)) mess14(langue,3,-1), nbduno
 421       write (ulsort,texte(langue,7)) mess14(langue,3,1), nbduno
 422 #endif
 423 c
 424       endif
 425 c
 426 c====
 427 c 4. la fin
 428 c====
 429 c
 430       if ( codret.ne.0 ) then
 431 c
 432 #include "envex2.h"
 433 c
 434       write (ulsort,texte(langue,1)) 'Sortie', nompro
 435       write (ulsort,texte(langue,2)) codret
 436 c
 437       endif
 438 c
 439 #ifdef _DEBUG_HOMARD_
 440       write (ulsort,texte(langue,1)) 'Sortie', nompro
 441       call dmflsh (iaux)
 442 #endif
 443 c
 444       end