src/tool/AP_Conversion/pcs2h2.F

   1       subroutine pcs2h2 ( nbfop2, profho, vap2ho,
   2      >                    somare, np2are,
   3      >                    listso, listno,
   4      >                    tbarcp, nbarhi, areint,
   5      >                    ulsort, langue, codret )
   6 c ______________________________________________________________________
   7 c
   8 c                             H O M A R D
   9 c
  10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  11 c
  12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  13 c aupres des huissiers de justice Simart et Lavoir a Clamart
  14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  15 c aupres des huissiers de justice
  16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  17 c
  18 c    HOMARD est une marque deposee d'Electricite de France
  19 c
  20 c Copyright EDF 1996
  21 c Copyright EDF 1998
  22 c Copyright EDF 2002
  23 c Copyright EDF 2020
  24 c ______________________________________________________________________
  25 c
  26 c    aPres adaptation - Conversion de Solution -
  27 c     -                 -             -
  28 c    interpolation p2 sur les noeuds - decoupage Hexaedres - 2
  29 c                   -                            -           -
  30 c    Du centre aux milieux d'aretes
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . nbfop2 . e   .    1   . nombre de fonctions P2                     .
  36 c . profho . es  .   *    . pour chaque entite en numerotation homard :.
  37 c .        .     .        . 0 : l'entite est absente du profil         .
  38 c .        .     .        . 1 : l'entite est presente dans le profil   .
  39 c . vap2ho . es  . nbfop2*. variables p2 numerotation homard           .
  40 c .        .     . nbnoto .                                            .
  41 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  42 c . np2are . e   . nbarto . numero des noeuds p2 milieux d'aretes      .
  43 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  44 c . filhex . e   . nbheto . premier fils des hexaedres                 .
  45 c . fhpyte . e   .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide   .
  46 c .        .     .        . fille de l'hexaedre k tel que filhex(k) =-j.
  47 c .        .     .        . fhpyte(2,j) = numero du 1er tetraedre      .
  48 c .        .     .        . fils de l'hexaedre k tel que filhex(k) = -j.
  49 c . listso . e   .    8   . liste des sommets de l'hexaedre            .
  50 c . listno . e   .   12   . liste des noeuds de l'hexaedre             .
  51 c . tbarcp . e   .  12    . 1/0 pour chaque arete coupee ou non        .
  52 c . nbarhi . e   .   1    . nombre d'aretes internes                   .
  53 c . areint . e   .   *    . numeros globaux des aretes internes        .
  54 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  55 c . langue . e   .    1   . langue des messages                        .
  56 c .        .     .        . 1 : francais, 2 : anglais                  .
  57 c . codret . es  .    1   . code de retour des modules                 .
  58 c .        .     .        . 0 : pas de probleme                        .
  59 c .        .     .        . 1 : probleme                               .
  60 c ______________________________________________________________________
  61 c
  62 c====
  63 c 0. declarations et dimensionnement
  64 c====
  65 c
  66 c 0.1. ==> generalites
  67 c
  68       implicit none
  69       save
  70 c
  71 #include "fractf.h"
  72 #include "fractg.h"
  73 #include "fracth.h"
  74 c
  75       character*6 nompro
  76       parameter ( nompro = 'PCS2H2' )
  77 c
  78 #include "nblang.h"
  79 c
  80 c 0.2. ==> communs
  81 c
  82 #include "envex1.h"
  83 c
  84 #include "nombar.h"
  85 c
  86 c 0.3. ==> arguments
  87 c
  88       integer nbfop2
  89       integer profho(*)
  90       integer somare(2,nbarto), np2are(nbarto)
  91       integer listso(8), listno(12)
  92       integer tbarcp(12), nbarhi, areint(nbarhi)
  93 c
  94       double precision vap2ho(nbfop2,*)
  95 c
  96       integer ulsort, langue, codret
  97 c
  98 c 0.4. ==> variables locales
  99 c
 100       integer iaux
 101 cgn      integer jaux
 102       integer larete
 103       integer listns(20)
 104       integer sm, nuv
 105       integer nuloar
 106 c
 107       integer nbmess
 108       parameter ( nbmess = 100 )
 109       character*80 texte(nblang,nbmess)
 110 c
 111 c ______________________________________________________________________
 112 c
 113 #include "impr01.h"
 114 c
 115 #include "impr03.h"
 116 c
 117 cgn        write (ulsort,texte(langue,1)) 'Entree', nompro
 118 #ifdef _DEBUG_HOMARD_
 119       write (ulsort,90002) 'listso', listso
 120       write (ulsort,90002) 'listno  1-8', (listno(iaux),iaux=1,8)
 121       write (ulsort,90002) 'listno 9-12', (listno(iaux),iaux=9,12)
 122       write (ulsort,90002) 'tbarcp  1-8', (tbarcp(iaux),iaux=1,8)
 123       write (ulsort,90002) 'tbarcp 9-12', (tbarcp(iaux),iaux=9,12)
 124 #endif
 125 c    On passe en revue toutes les aretes coupees
 126 c
 127       do 10 , nuloar = 1 , 12
 128 c
 129         if ( tbarcp(nuloar).eq.1 ) then
 130 c
 131 c====
 132 c 1. Reperage des sommets et des noeuds
 133 c====
 134 c         le milieu de l'arete coupee
 135           listns( 9) = listno(nuloar)
 136 c         le milieu de l'arete opposee
 137           listns(20) = listno(13-nuloar)
 138 c
 139 c 1.1. ==> Arete 1
 140 c
 141           if ( nuloar.eq.1 ) then
 142 c
 143 c           les sommets de l'arete coupee
 144             listns( 1) = listso(1)
 145             listns( 2) = listso(2)
 146 c           les autres sommets
 147             listns( 3) = listso(3)
 148             listns( 4) = listso(4)
 149             listns( 5) = listso(5)
 150             listns( 6) = listso(6)
 151 c           les sommets de l'arete opposee a l'arete coupee
 152             listns( 7) = listso(7)
 153             listns( 8) = listso(8)
 154 c           les milieux des aretes proches
 155             listns(10) = listno( 2)
 156             listns(11) = listno( 3)
 157             listns(12) = listno( 5)
 158             listns(13) = listno( 6)
 159 c           les milieux des aretes paralleles
 160             listns(14) = listno( 4)
 161             listns(15) = listno( 9)
 162 c           les milieux des aretes moins proches
 163             listns(16) = listno( 7)
 164             listns(17) = listno( 8)
 165             listns(18) = listno(10)
 166             listns(19) = listno(11)
 167 c
 168 c 1.2. ==> Arete 2
 169 c
 170           elseif ( nuloar.eq.2 ) then
 171 c
 172 c           les sommets de l'arete coupee
 173             listns( 1) = listso(1)
 174             listns( 2) = listso(4)
 175 c           les autres sommets
 176             listns( 3) = listso(2)
 177             listns( 4) = listso(3)
 178             listns( 5) = listso(6)
 179             listns( 6) = listso(7)
 180 c           les sommets de l'arete opposee a l'arete coupee
 181             listns( 7) = listso(5)
 182             listns( 8) = listso(8)
 183 c           les milieux des aretes proches
 184             listns(10) = listno( 1)
 185             listns(11) = listno( 4)
 186             listns(12) = listno( 5)
 187             listns(13) = listno( 7)
 188 c           les milieux des aretes paralleles
 189             listns(14) = listno( 3)
 190             listns(15) = listno(10)
 191 c           les milieux des aretes moins proches
 192             listns(16) = listno( 6)
 193             listns(17) = listno( 8)
 194             listns(18) = listno( 9)
 195             listns(19) = listno(12)
 196 c
 197 c 1.3. ==> Arete 3
 198 c
 199           elseif ( nuloar.eq.3 ) then
 200 c
 201 c           les sommets de l'arete coupee
 202             listns( 1) = listso(2)
 203             listns( 2) = listso(3)
 204 c           les autres sommets
 205             listns( 3) = listso(1)
 206             listns( 4) = listso(4)
 207             listns( 5) = listso(5)
 208             listns( 6) = listso(8)
 209 c           les sommets de l'arete opposee a l'arete coupee
 210             listns( 7) = listso(6)
 211             listns( 8) = listso(7)
 212 c           les milieux des aretes proches
 213             listns(10) = listno( 1)
 214             listns(11) = listno( 4)
 215             listns(12) = listno( 6)
 216             listns(13) = listno( 8)
 217 c           les milieux des aretes paralleles
 218             listns(14) = listno( 2)
 219             listns(15) = listno(11)
 220 c           les milieux des aretes moins proches
 221             listns(16) = listno( 5)
 222             listns(17) = listno( 7)
 223             listns(18) = listno( 9)
 224             listns(19) = listno(12)
 225 c
 226 c 1.2. ==> Arete 4
 227 c
 228           elseif ( nuloar.eq.4 ) then
 229 c
 230 c           les sommets de l'arete coupee
 231             listns( 1) = listso(3)
 232             listns( 2) = listso(4)
 233 c           les autres sommets
 234             listns( 3) = listso(1)
 235             listns( 4) = listso(2)
 236             listns( 5) = listso(7)
 237             listns( 6) = listso(8)
 238 c           les sommets de l'arete opposee a l'arete coupee
 239             listns( 7) = listso(5)
 240             listns( 8) = listso(6)
 241 c           les milieux des aretes proches
 242             listns(10) = listno( 2)
 243             listns(11) = listno( 3)
 244             listns(12) = listno( 7)
 245             listns(13) = listno( 8)
 246 c           les milieux des aretes paralleles
 247             listns(14) = listno( 1)
 248             listns(15) = listno(12)
 249 c           les milieux des aretes moins proches
 250             listns(16) = listno( 5)
 251             listns(17) = listno( 6)
 252             listns(18) = listno(10)
 253             listns(19) = listno(11)
 254 c
 255 c 1.5. ==> Arete 5
 256 c
 257           elseif ( nuloar.eq.5 ) then
 258 c
 259 c           les sommets de l'arete coupee
 260             listns( 1) = listso(1)
 261             listns( 2) = listso(6)
 262 c           les autres sommets
 263             listns( 3) = listso(2)
 264             listns( 4) = listso(4)
 265             listns( 5) = listso(5)
 266             listns( 6) = listso(7)
 267 c           les sommets de l'arete opposee a l'arete coupee
 268             listns( 7) = listso(3)
 269             listns( 8) = listso(8)
 270 c           les milieux des aretes proches
 271             listns(10) = listno( 1)
 272             listns(11) = listno( 2)
 273             listns(12) = listno( 9)
 274             listns(13) = listno(10)
 275 c           les milieux des aretes paralleles
 276             listns(14) = listno( 6)
 277             listns(15) = listno( 7)
 278 c           les milieux des aretes moins proches
 279             listns(16) = listno( 3)
 280             listns(17) = listno( 4)
 281             listns(18) = listno(11)
 282             listns(19) = listno(12)
 283 c
 284 c 1.6. ==> Arete 6
 285 c
 286           elseif ( nuloar.eq.6 ) then
 287 c
 288 c           les sommets de l'arete coupee
 289             listns( 1) = listso(2)
 290             listns( 2) = listso(5)
 291 c           les autres sommets
 292             listns( 3) = listso(1)
 293             listns( 4) = listso(3)
 294             listns( 5) = listso(6)
 295             listns( 6) = listso(8)
 296 c           les sommets de l'arete opposee a l'arete coupee
 297             listns( 7) = listso(4)
 298             listns( 8) = listso(7)
 299 c           les milieux des aretes proches
 300             listns(10) = listno( 1)
 301             listns(11) = listno( 3)
 302             listns(12) = listno( 9)
 303             listns(13) = listno(11)
 304 c           les milieux des aretes paralleles
 305             listns(14) = listno( 5)
 306             listns(15) = listno( 8)
 307 c           les milieux des aretes moins proches
 308             listns(16) = listno( 2)
 309             listns(17) = listno( 4)
 310             listns(18) = listno(10)
 311             listns(19) = listno(12)
 312 c
 313 c 1.7. ==> Arete 7
 314 c
 315           elseif ( nuloar.eq.7 ) then
 316 c
 317 c           les sommets de l'arete coupee
 318             listns( 1) = listso(4)
 319             listns( 2) = listso(7)
 320 c           les autres sommets
 321             listns( 3) = listso(1)
 322             listns( 4) = listso(3)
 323             listns( 5) = listso(6)
 324             listns( 6) = listso(8)
 325 c           les sommets de l'arete opposee a l'arete coupee
 326             listns( 7) = listso(2)
 327             listns( 8) = listso(5)
 328 c           les milieux des aretes proches
 329             listns(10) = listno( 2)
 330             listns(11) = listno( 4)
 331             listns(12) = listno(10)
 332             listns(13) = listno(12)
 333 c           les milieux des aretes paralleles
 334             listns(14) = listno( 5)
 335             listns(15) = listno( 8)
 336 c           les milieux des aretes moins proches
 337             listns(16) = listno( 1)
 338             listns(17) = listno( 3)
 339             listns(18) = listno( 9)
 340             listns(19) = listno(11)
 341 c
 342 c 1.8. ==> Arete 8
 343 c
 344           elseif ( nuloar.eq.8 ) then
 345 c
 346 c           les sommets de l'arete coupee
 347             listns( 1) = listso(3)
 348             listns( 2) = listso(8)
 349 c           les autres sommets
 350             listns( 3) = listso(2)
 351             listns( 4) = listso(4)
 352             listns( 5) = listso(5)
 353             listns( 6) = listso(7)
 354 c           les sommets de l'arete opposee a l'arete coupee
 355             listns( 7) = listso(1)
 356             listns( 8) = listso(6)
 357 c           les milieux des aretes proches
 358             listns(10) = listno( 3)
 359             listns(11) = listno( 4)
 360             listns(12) = listno(11)
 361             listns(13) = listno(12)
 362 c           les milieux des aretes paralleles
 363             listns(14) = listno( 6)
 364             listns(15) = listno( 7)
 365 c           les milieux des aretes moins proches
 366             listns(16) = listno( 1)
 367             listns(17) = listno( 2)
 368             listns(18) = listno( 9)
 369             listns(19) = listno(10)
 370 c
 371 c 1.9. ==> Arete 9
 372 c
 373           elseif ( nuloar.eq.9 ) then
 374 c
 375 c           les sommets de l'arete coupee
 376             listns( 1) = listso(5)
 377             listns( 2) = listso(6)
 378 c           les autres sommets
 379             listns( 3) = listso(1)
 380             listns( 4) = listso(2)
 381             listns( 5) = listso(7)
 382             listns( 6) = listso(8)
 383 c           les sommets de l'arete opposee a l'arete coupee
 384             listns( 7) = listso(3)
 385             listns( 8) = listso(4)
 386 c           les milieux des aretes proches
 387             listns(10) = listno( 5)
 388             listns(11) = listno( 6)
 389             listns(12) = listno(10)
 390             listns(13) = listno(11)
 391 c           les milieux des aretes paralleles
 392             listns(14) = listno( 1)
 393             listns(15) = listno(12)
 394 c           les milieux des aretes moins proches
 395             listns(16) = listno( 2)
 396             listns(17) = listno( 3)
 397             listns(18) = listno( 7)
 398             listns(19) = listno( 8)
 399 c
 400 c 1.10. ==> Arete 10
 401 c
 402           elseif ( nuloar.eq.10 ) then
 403 c
 404 c           les sommets de l'arete coupee
 405             listns( 1) = listso(6)
 406             listns( 2) = listso(7)
 407 c           les autres sommets
 408             listns( 3) = listso(1)
 409             listns( 4) = listso(4)
 410             listns( 5) = listso(5)
 411             listns( 6) = listso(8)
 412 c           les sommets de l'arete opposee a l'arete coupee
 413             listns( 7) = listso(2)
 414             listns( 8) = listso(3)
 415 c           les milieux des aretes proches
 416             listns(10) = listno( 5)
 417             listns(11) = listno( 7)
 418             listns(12) = listno( 9)
 419             listns(13) = listno(12)
 420 c           les milieux des aretes paralleles
 421             listns(14) = listno( 2)
 422             listns(15) = listno(11)
 423 c           les milieux des aretes moins proches
 424             listns(16) = listno( 1)
 425             listns(17) = listno( 4)
 426             listns(18) = listno( 6)
 427             listns(19) = listno( 8)
 428 c
 429 c 1.11. ==> Arete 11
 430 c
 431           elseif ( nuloar.eq.11 ) then
 432 c
 433 c           les sommets de l'arete coupee
 434             listns( 1) = listso(5)
 435             listns( 2) = listso(8)
 436 c           les autres sommets
 437             listns( 3) = listso(2)
 438             listns( 4) = listso(3)
 439             listns( 5) = listso(6)
 440             listns( 6) = listso(7)
 441 c           les sommets de l'arete opposee a l'arete coupee
 442             listns( 7) = listso(1)
 443             listns( 8) = listso(4)
 444 c           les milieux des aretes proches
 445             listns(10) = listno( 6)
 446             listns(11) = listno( 8)
 447             listns(12) = listno( 9)
 448             listns(13) = listno(12)
 449 c           les milieux des aretes paralleles
 450             listns(14) = listno( 3)
 451             listns(15) = listno(10)
 452 c           les milieux des aretes moins proches
 453             listns(16) = listno( 1)
 454             listns(17) = listno( 4)
 455             listns(18) = listno( 5)
 456             listns(19) = listno( 7)
 457 c
 458 c 1.12. ==> Arete 12
 459 c
 460           elseif ( nuloar.eq.12 ) then
 461 c
 462 c           les sommets de l'arete coupee
 463             listns( 1) = listso(7)
 464             listns( 2) = listso(8)
 465 c           les autres sommets
 466             listns( 3) = listso(3)
 467             listns( 4) = listso(4)
 468             listns( 5) = listso(5)
 469             listns( 6) = listso(6)
 470 c           les sommets de l'arete opposee a l'arete coupee
 471             listns( 7) = listso(1)
 472             listns( 8) = listso(2)
 473 c           les milieux des aretes proches
 474             listns(10) = listno( 7)
 475             listns(11) = listno( 8)
 476             listns(12) = listno(10)
 477             listns(13) = listno(11)
 478 c           les milieux des aretes paralleles
 479             listns(14) = listno( 4)
 480             listns(15) = listno( 9)
 481 c           les milieux des aretes moins proches
 482             listns(16) = listno( 2)
 483             listns(17) = listno( 3)
 484             listns(18) = listno( 5)
 485             listns(19) = listno( 6)
 486 c
 487           endif
 488 c
 489 c====
 490 c 2. L'arete concernee : celle des aretes internes qui demarrent
 491 c          sur le milieu de l'arete coupee
 492 c====
 493 c
 494           do 22 , iaux = 1 , nbarhi
 495             larete = areint(iaux)
 496             if ( somare(1,larete).eq.listns( 9) ) then
 497               sm = np2are(larete)
 498               goto 220
 499             endif
 500   22     continue
 501       write(ulsort,*) nompro//' - aucune arete interne ne correspond ?'
 502       codret = 22
 503 c
 504   220     continue
 505 c
 506 c====
 507 c 3. Calcul
 508 c====
 509 c
 510           if ( codret.eq.0 ) then
 511 c
 512           profho(sm) = 1
 513 c
 514           do 31, nuv = 1 , nbfop2
 515 cgn          do 311 , jaux =1 ,20
 516 cgn        write(*,90014) listns(jaux), vap2ho(nuv,listns(jaux))
 517 cgn  311 continue
 518 c
 519           vap2ho(nuv,sm) = - nfstr2 * ( vap2ho(nuv,listns(1))
 520      >                                + vap2ho(nuv,listns(2)) )
 521      >                     - trssz  * ( vap2ho(nuv,listns(3))
 522      >                                + vap2ho(nuv,listns(4))
 523      >                                + vap2ho(nuv,listns(5))
 524      >                                + vap2ho(nuv,listns(6)) )
 525      >                     - trstr2 * ( vap2ho(nuv,listns(7))
 526      >                                + vap2ho(nuv,listns(8)) )
 527      >                     + nessz  *   vap2ho(nuv,listns(9))
 528      >                     + nfstr2 * ( vap2ho(nuv,listns(10))
 529      >                                + vap2ho(nuv,listns(11))
 530      >                                + vap2ho(nuv,listns(12))
 531      >                                + vap2ho(nuv,listns(13)) )
 532      >                     + trssz  * ( vap2ho(nuv,listns(14))
 533      >                                + vap2ho(nuv,listns(15)) )
 534      >                     + trstr2 * ( vap2ho(nuv,listns(16))
 535      >                                + vap2ho(nuv,listns(17))
 536      >                                + vap2ho(nuv,listns(18))
 537      >                                + vap2ho(nuv,listns(19)) )
 538      >                     + unssz  *   vap2ho(nuv,listns(20))
 539 c
 540 cgn        write(*,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm)
 541    31     continue
 542 c
 543           endif
 544 c
 545         endif
 546 c
 547    10 continue
 548 c
 549 c====
 550 c 4. La fin
 551 c====
 552 c
 553       if ( codret.ne.0 ) then
 554 c
 555 #include "envex2.h"
 556 c
 557       write (ulsort,texte(langue,1)) 'Sortie', nompro
 558       write (ulsort,texte(langue,2)) codret
 559 c
 560       endif
 561 c
 562 #ifdef _DEBUG_HOMARD_
 563       write (ulsort,texte(langue,1)) 'Sortie', nompro
 564       call dmflsh (iaux)
 565 #endif
 566 c
 567       end