src/tool/AP_Conversion/pcmahe.F

   1       subroutine pcmahe ( elemen, nbele0,
   2      >                    somare, np2are,
   3      >                    arequa,
   4      >                    quahex, coquhe, arehex,
   5      >                    hethex, ninhex,
   6      >                    famhex, cfahex,
   7      >                    nnosca, nhesca, nhesho,
   8      >                    famele, noeele, typele,
   9      >                    ulsort, langue, codret )
  10 c ______________________________________________________________________
  11 c
  12 c                             H O M A R D
  13 c
  14 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  15 c
  16 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  17 c aupres des huissiers de justice Simart et Lavoir a Clamart
  18 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  19 c aupres des huissiers de justice
  20 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  21 c
  22 c    HOMARD est une marque deposee d'Electricite de France
  23 c
  24 c Copyright EDF 1996
  25 c Copyright EDF 1998
  26 c Copyright EDF 2002
  27 c Copyright EDF 2020
  28 c ______________________________________________________________________
  29 c
  30 c    aPres adaptation - Conversion - MAillage connectivite - HExaedres
  31 c     -                 -            --                      --
  32 c ______________________________________________________________________
  33 c .        .     .        .                                            .
  34 c .  nom   . e/s . taille .           description                      .
  35 c .____________________________________________________________________.
  36 c . elemen . es  .   1    . numero du dernier element cree             .
  37 c . nbele0 . e   .   1    . estimation du nombre d'elements            .
  38 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  39 c . np2are . e   . nbarto . numero du noeud p2 milieu d'arete          .
  40 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  41 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  42 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  43 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  44 c . ninhex . e   . nbheto . noeud interne a l'hexaedre                 .
  45 c . famhex . e   . nbheto . famille des hexaedres                      .
  46 c . cfahex .     . nctfhe. codes des familles des hexaedres            .
  47 c .        .     . nbfhex .   1 : famille MED                          .
  48 c .        .     .        .   2 : type d'hexaedres                     .
  49 c .        .     .        .   3 : famille des tetraedres de conformite .
  50 c .        .     .        .   4 : famille des pyramides de conformite  .
  51 c . nnosca . e   . rsnoto . numero des noeuds du code de calcul        .
  52 c . nhesca .  s  . rsheto . numero des hexaedres dans le calcul        .
  53 c . nhesho .  s  . nbele0 . numero des hexaedres dans HOMARD           .
  54 c . famele . es  . nbele0 . famille med des elements                   .
  55 c . noeele . es  . nbele0 . noeuds des elements                        .
  56 c .        .     . *nbmane.                                            .
  57 c . typele . es  . nbele0 . type des elements                          .
  58 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  59 c . langue . e   .    1   . langue des messages                        .
  60 c .        .     .        . 1 : francais, 2 : anglais                  .
  61 c . codret . es  .    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 = 'PCMAHE' )
  77 c
  78 #include "nblang.h"
  79 #include "coftex.h"
  80 c
  81 c 0.2. ==> communs
  82 c
  83 #include "envex1.h"
  84 c
  85 #include "impr02.h"
  86 #include "envca1.h"
  87 c
  88 #include "nbfami.h"
  89 #include "nombar.h"
  90 #include "nombqu.h"
  91 #include "nombhe.h"
  92 c
  93 #include "nombsr.h"
  94 c
  95 #include "dicfen.h"
  96 c
  97 c 0.3. ==> arguments
  98 c
  99       integer elemen
 100       integer nbele0
 101 c
 102       integer somare(2,nbarto), np2are(nbarto)
 103       integer arequa(nbquto,4)
 104       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 105       integer hethex(nbheto), ninhex(nbheto)
 106 c
 107       integer cfahex(nctfhe,nbfhex), famhex(nbheto)
 108 c
 109       integer nnosca(rsnoto)
 110       integer nhesca(rsheto), nhesho(nbele0)
 111 c
 112       integer famele(nbele0), noeele(nbele0,nbmane)
 113       integer typele(nbele0)
 114 c
 115       integer ulsort, langue, codret
 116 c
 117 c 0.4. ==> variables locales
 118 c
 119       integer lehexa, lehex0
 120       integer etat
 121       integer iaux
 122       integer listar(12), listso(20), nomiar(12)
 123 #ifdef _DEBUG_HOMARD_
 124       integer glop
 125 #endif
 126 c
 127       integer nbmess
 128       parameter ( nbmess = 20 )
 129       character*80 texte(nblang,nbmess)
 130 c
 131 c 0.5. ==> initialisations
 132 c ______________________________________________________________________
 133 c
 134 c====
 135 c 1. initialisations
 136 c====
 137 c
 138 #include "impr01.h"
 139 c
 140 #ifdef _DEBUG_HOMARD_
 141       write (ulsort,texte(langue,1)) 'Entree', nompro
 142       call dmflsh (iaux)
 143 #endif
 144 c
 145 #ifdef _DEBUG_HOMARD_
 146       write(ulsort,90002) 'nbhecf, nbheca =', nbhecf, nbheca
 147 #endif
 148 c
 149 #include "impr03.h"
 150 c
 151 #include "impr06.h"
 152 c
 153 c====
 154 c 2. initialisations des renumerotations
 155 c====
 156 c
 157       do 21 , iaux = 1 , rsheto
 158         nhesca(iaux) = 0
 159    21 continue
 160 c
 161       do 22 , iaux = 1 , nbele0
 162         nhesho(iaux) = 0
 163    22 continue
 164 c
 165 c====
 166 c 3. Conversion en lineaire
 167 c====
 168 c
 169       if ( degre.eq.1 ) then
 170 c
 171 c             1                   4
 172 c             --------------------
 173 c            /                   /.
 174 c           /                   / .
 175 c          /                   /  .
 176 c         /                   /   .
 177 c       2 -------------------- 3  .
 178 c         .                  .    .
 179 c         .                  .    .
 180 c         .    5             .    . 8
 181 c         .                  .   /
 182 c         .                  .  /
 183 c         .                  . /
 184 c         .                  ./
 185 c         --------------------
 186 c         6                  7
 187 c
 188 c    . Les noeuds (1,2,3,4) definissent un quadrangle a orientation
 189 c      vers l'exterieur
 190 c    . Les noeuds (5,6,7,8) sont translates de (1,2,3,4)
 191 c    . Le triedre (1-->2,1-->5,1-->4) est direct
 192 c
 193
 194         do 31 , lehex0 = 1 , nbheto
 195 c
 196           lehexa = lehex0
 197 c
 198 #ifdef _DEBUG_HOMARD_
 199       write (ulsort,texte(langue,11)) mess14(langue,2,6), lehexa
 200 #endif
 201 c
 202           etat = mod(hethex(lehexa),1000)
 203 c
 204           if ( etat.eq.0 .or. hierar.ne.0 ) then
 205 c
 206             elemen = elemen + 1
 207 #ifdef _DEBUG_HOMARD_
 208         if ( elemen.eq.-12 ) then
 209           glop = 1
 210         else
 211           glop = 0
 212         endif
 213 #endif
 214 #ifdef _DEBUG_HOMARD_
 215         if ( glop.ne.0 ) then
 216             write (ulsort,texte(langue,14)) elemen
 217         endif
 218 #endif
 219             nhesho(elemen) = lehexa
 220             nhesca(lehexa) = elemen
 221 c
 222 #ifdef _DEBUG_HOMARD_
 223       write (ulsort,texte(langue,3)) 'UTASHE', nompro
 224 #endif
 225             call utashe ( lehexa,
 226      >                    nbquto, nbhecf, nbheca,
 227      >                    somare, arequa,
 228      >                    quahex, coquhe, arehex,
 229      >                    listar, listso )
 230 c
 231 c     Attention : utashe donne la numerotation dans la convention homard
 232 c                 il faut permuter les sommets 5/6 et 7/8 pour obtenir
 233 c                 la numerotation dans la convention med
 234 c
 235             noeele(elemen,1) = nnosca(listso(1))
 236             noeele(elemen,2) = nnosca(listso(2))
 237             noeele(elemen,3) = nnosca(listso(3))
 238             noeele(elemen,4) = nnosca(listso(4))
 239             noeele(elemen,6) = nnosca(listso(5))
 240             noeele(elemen,5) = nnosca(listso(6))
 241             noeele(elemen,8) = nnosca(listso(7))
 242             noeele(elemen,7) = nnosca(listso(8))
 243 c
 244             famele(elemen) = cfahex(cofamd,famhex(lehexa))
 245             typele(elemen) = cfahex(cotyel,famhex(lehexa))
 246 c
 247 #ifdef _DEBUG_HOMARD_
 248 cgn        if ( glop.ne.0 ) then
 249             write (ulsort,90002) 'famhex', famhex(lehexa)
 250             write (ulsort,texte(langue,14)) elemen
 251             write (ulsort,texte(langue,15))
 252      >             (noeele(elemen,iaux),iaux=1,8)
 253             write (ulsort,90002) 'Famille MED',famele(elemen)
 254             write (ulsort,90002) 'Type MED   ',typele(elemen)
 255 cgn            endif
 256 #endif
 257 c
 258           endif
 259 c
 260   31   continue
 261 c
 262 c====
 263 c 4. Conversion en quadratique
 264 c====
 265 c
 266       elseif ( mod(mailet,5).gt.0 ) then
 267 c
 268 c             1                   4
 269 c             ---------12---------
 270 c            /                   /.
 271 c          9/                   11.
 272 c          /                   /  .
 273 c         /   17              /   .
 274 c       2 ---------10---------3   20
 275 c         .                  .    .
 276 c         .                  .    .
 277 c         .    5       16    .    . 8
 278 c       18.                  .19 /
 279 c         .  13              .  /15
 280 c         .                  . /
 281 c         .                  ./
 282 c         ---------14---------
 283 c         6                  7
 284 c
 285 c    . Les noeuds (1,2,3,4) definissent un quadrangle a orientation
 286 c      vers l'exterieur
 287 c    . Les noeuds (5,6,7,8) sont translates de (1,2,3,4)
 288 c    . Le triedre (1-->2,1-->5,1-->4) est direct
 289 c
 290 c            Au sens homard      au sens MED
 291 c          arete  1 de s1 a s2 | de s1 a s2
 292 c          arete  2 de s1 a s4 | de s1 a s4
 293 c          arete  3 de s2 a s3 | de s2 a s3
 294 c          arete  4 de s3 a s4 | de s3 a s4
 295 c          arete  5 de s1 a s6 | de s1 a s5
 296 c          arete  6 de s2 a s5 | de s2 a s6
 297 c          arete  7 de s4 a s7 | de s4 a s8
 298 c          arete  8 de s3 a s8 | de s3 a s7
 299 c          arete  9 de s5 a s6 | de s6 a s5
 300 c          arete 10 de s6 a s7 | de s5 a s8
 301 c          arete 11 de s5 a s8 | de s6 a s7
 302 c          arete 12 de s7 a s8 | de s8 a s7
 303 c       Tableau de travail nomiar :
 304 c       nomiar(i) contient le numero local au sens MED du noeud porte
 305 c       par l'arete de numero local i au sens homard
 306 c
 307         nomiar( 1) =  9
 308         nomiar( 2) = 12
 309         nomiar( 3) = 10
 310         nomiar( 4) = 11
 311         nomiar( 5) = 17
 312         nomiar( 6) = 18
 313         nomiar( 7) = 20
 314         nomiar( 8) = 19
 315         nomiar( 9) = 13
 316         nomiar(10) = 16
 317         nomiar(11) = 14
 318         nomiar(12) = 15
 319 c
 320         do 41 , lehex0 = 1 , nbheto
 321 c
 322           lehexa = lehex0
 323 c
 324 #ifdef _DEBUG_HOMARD_
 325         if ( elemen.eq.-12 ) then
 326           glop = 1
 327         else
 328           glop = 0
 329         endif
 330 #endif
 331 c
 332 #ifdef _DEBUG_HOMARD_
 333       write (ulsort,texte(langue,11)) mess14(langue,2,6), lehexa
 334 #endif
 335 c
 336           etat = mod(hethex(lehexa),1000)
 337 c
 338           if ( etat.eq.0 .or. hierar.ne.0 ) then
 339 c
 340             elemen = elemen + 1
 341 #ifdef _DEBUG_HOMARD_
 342         if ( glop.ne.0 ) then
 343             write (ulsort,texte(langue,14)) elemen
 344         endif
 345 #endif
 346             nhesho(elemen) = lehexa
 347             nhesca(lehexa) = elemen
 348 c
 349 #ifdef _DEBUG_HOMARD_
 350       write (ulsort,texte(langue,3)) 'UTASHE', nompro
 351 #endif
 352             call utashe ( lehexa,
 353      >                    nbquto, nbhecf, nbheca,
 354      >                    somare, arequa,
 355      >                    quahex, coquhe, arehex,
 356      >                    listar, listso )
 357 c
 358 c     Attention : utashe donne la numerotation dans la convention homard
 359 c                 il faut permuter les sommets 5/6 et 7/8pour obtenir la
 360 c                 numerotation dans la convention med
 361 c
 362             noeele(elemen,1) = nnosca(listso(1))
 363             noeele(elemen,2) = nnosca(listso(2))
 364             noeele(elemen,3) = nnosca(listso(3))
 365             noeele(elemen,4) = nnosca(listso(4))
 366             noeele(elemen,6) = nnosca(listso(5))
 367             noeele(elemen,5) = nnosca(listso(6))
 368             noeele(elemen,8) = nnosca(listso(7))
 369             noeele(elemen,7) = nnosca(listso(8))
 370 c
 371 c     Les noeuds au milieu des aretes
 372 c
 373             do 411 , iaux = 1 , 12
 374               noeele(elemen,nomiar(iaux)) = nnosca(np2are(listar(iaux)))
 375   411       continue
 376 c
 377 c     Les noeuds internes
 378 c
 379             if ( mod(mailet,5).eq.0 ) then
 380               noeele(elemen,27) = nnosca(ninhex(lehexa))
 381             endif
 382 c
 383             famele(elemen) = cfahex(cofamd,famhex(lehexa))
 384             typele(elemen) = cfahex(cotyel,famhex(lehexa))
 385 c
 386           endif
 387 c
 388   41   continue
 389 c
 390 c
 391 c====
 392 c 4. Conversion en quadratique etendu
 393 c    Similaire au quadratique a part les noeuds de 21 a 27
 394 c====
 395 c
 396       else
 397 c
 398 c             1                   4
 399 c             ---------12---------
 400 c            /                   /.
 401 c          9/                   11.
 402 c          /                   /  .
 403 c         /   17              /   .
 404 c       2 ---------10---------3   20
 405 c         .                  .    .
 406 c         .                  .    .
 407 c         .    5       16    .    . 8
 408 c       18.                  .19 /
 409 c         .  13              .  /15
 410 c         .                  . /
 411 c         .                  ./
 412 c         ---------14---------
 413 c         6                  7
 414 c
 415 c    . Les noeuds (1,2,3,4) definissent un quadrangle a orientation
 416 c      vers l'exterieur
 417 c    . Les noeuds (5,6,7,8) sont translates de (1,2,3,4)
 418 c    . Le triedre (1-->2,1-->5,1-->4) est direct
 419 c
 420 c            Au sens homard      au sens MED
 421 c          arete  1 de s1 a s2 | de s1 a s2
 422 c          arete  2 de s1 a s4 | de s1 a s4
 423 c          arete  3 de s2 a s3 | de s2 a s3
 424 c          arete  4 de s3 a s4 | de s3 a s4
 425 c          arete  5 de s1 a s6 | de s1 a s5
 426 c          arete  6 de s2 a s5 | de s2 a s6
 427 c          arete  7 de s4 a s7 | de s4 a s8
 428 c          arete  8 de s3 a s8 | de s3 a s7
 429 c          arete  9 de s5 a s6 | de s6 a s5
 430 c          arete 10 de s6 a s7 | de s5 a s8
 431 c          arete 11 de s5 a s8 | de s6 a s7
 432 c          arete 12 de s7 a s8 | de s8 a s7
 433 c       Tableau de travail nomiar :
 434 c       nomiar(i) contient le numero local au sens MED du noeud porte
 435 c       par l'arete de numero local i au sens homard
 436 c
 437         nomiar( 1) =  9
 438         nomiar( 2) = 12
 439         nomiar( 3) = 10
 440         nomiar( 4) = 11
 441         nomiar( 5) = 17
 442         nomiar( 6) = 18
 443         nomiar( 7) = 20
 444         nomiar( 8) = 19
 445         nomiar( 9) = 13
 446         nomiar(10) = 16
 447         nomiar(11) = 14
 448         nomiar(12) = 15
 449 c
 450         do 51 , lehex0 = 1 , nbheto
 451 c
 452           lehexa = lehex0
 453 c
 454 #ifdef _DEBUG_HOMARD_
 455         if ( elemen.eq.-12 ) then
 456           glop = 1
 457         else
 458           glop = 0
 459         endif
 460 #endif
 461 c
 462 #ifdef _DEBUG_HOMARD_
 463       write (ulsort,texte(langue,11)) mess14(langue,2,6), lehexa
 464 #endif
 465 c
 466           etat = mod(hethex(lehexa),1000)
 467 c
 468           if ( etat.eq.0 .or. hierar.ne.0 ) then
 469 c
 470             elemen = elemen + 1
 471 #ifdef _DEBUG_HOMARD_
 472         if ( glop.ne.0 ) then
 473             write (ulsort,texte(langue,14)) elemen
 474         endif
 475 #endif
 476             nhesho(elemen) = lehexa
 477             nhesca(lehexa) = elemen
 478 #ifdef _DEBUG_HOMARD_
 479       write (ulsort,texte(langue,3)) 'UTASHE', nompro
 480 #endif
 481             call utashe ( lehexa,
 482      >                    nbquto, nbhecf, nbheca,
 483      >                    somare, arequa,
 484      >                    quahex, coquhe, arehex,
 485      >                    listar, listso )
 486 c
 487 c     Attention : utashe donne la numerotation dans la convention homard
 488 c                 il faut permuter les sommets 5/6 et 7/8pour obtenir la
 489 c                 numerotation dans la convention med
 490 c
 491             noeele(elemen,1) = nnosca(listso(1))
 492             noeele(elemen,2) = nnosca(listso(2))
 493             noeele(elemen,3) = nnosca(listso(3))
 494             noeele(elemen,4) = nnosca(listso(4))
 495             noeele(elemen,6) = nnosca(listso(5))
 496             noeele(elemen,5) = nnosca(listso(6))
 497             noeele(elemen,8) = nnosca(listso(7))
 498             noeele(elemen,7) = nnosca(listso(8))
 499 c
 500 c     Les noeuds au milieu des aretes
 501 c
 502             do 512 , iaux = 1 , 12
 503               noeele(elemen,nomiar(iaux)) = nnosca(np2are(listar(iaux)))
 504   512       continue
 505 c
 506 c     Les noeuds internes
 507 c
 508             noeele(elemen,27) = nnosca(ninhex(lehexa))
 509 c
 510             famele(elemen) = cfahex(cofamd,famhex(lehexa))
 511             typele(elemen) = cfahex(cotyel,famhex(lehexa))
 512 c
 513           endif
 514 c
 515   51   continue
 516 c
 517       endif
 518 c
 519 c====
 520 c 6. la fin
 521 c====
 522 c
 523       if ( codret.ne.0 ) then
 524 c
 525 #include "envex2.h"
 526 c
 527       write (ulsort,texte(langue,1)) 'Sortie', nompro
 528       write (ulsort,texte(langue,2)) codret
 529 c
 530       endif
 531 c
 532 #ifdef _DEBUG_HOMARD_
 533       write (ulsort,texte(langue,1)) 'Sortie', nompro
 534       call dmflsh (iaux)
 535 #endif
 536 c
 537       end