src/tool/AP_Conversion/pcs2p3.F

   1       subroutine pcs2p3 ( nbfop2, profho, vap2ho,
   2      >                    np2are,
   3      >                    etapen,
   4      >                    listso, listno,
   5      >                    nbarco, nuaret )
   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 des Pentaedres - 3
  29 c                   -                                -            -
  30 c    Du centre aux sommets
  31 c remarque : pcs2p3 et pcsip3 sont des clones
  32 c ______________________________________________________________________
  33 c .        .     .        .                                            .
  34 c .  nom   . e/s . taille .           description                      .
  35 c .____________________________________________________________________.
  36 c . nbfop2 . e   .    1   . nombre de fonctions P2                     .
  37 c . profho . es  .   *    . pour chaque entite en numerotation homard :.
  38 c .        .     .        . 0 : l'entite est absente du profil         .
  39 c .        .     .        . 1 : l'entite est presente dans le profil   .
  40 c . vap2ho . es  . nbfop2*. variables p2 numerotation homard           .
  41 c .        .     . nbnoto .                                            .
  42 c . np2are . e   . nbarto . numero des noeuds p2 milieux d'aretes      .
  43 c . etapen . e   .    1   . etat du pentaedre a traiter                .
  44 c . listso . e   .    6   . Liste des sommets ordonnes du pentaedre    .
  45 c . listno . e   .    9   . Liste des noeuds ordonnees du pentaedre    .
  46 c . nbarco . e   .   1    . nombre d'aretes concernees                 .
  47 c . nuaret . e   . nbarco . numero des aretes a traiter                .
  48 c ______________________________________________________________________
  49 c
  50 c====
  51 c 0. declarations et dimensionnement
  52 c====
  53 c
  54 c 0.1. ==> generalites
  55 c
  56       implicit none
  57       save
  58 c
  59 #include "fract0.h"
  60 #include "fracta.h"
  61 #include "fractb.h"
  62 #include "fractf.h"
  63 #include "fractk.h"
  64 #include "fractm.h"
  65 #include "fractn.h"
  66 #include "fracto.h"
  67 c
  68 c 0.2. ==> communs
  69 c
  70 #include "nombar.h"
  71 c
  72 c 0.3. ==> arguments
  73 c
  74       integer nbfop2
  75       integer profho(*)
  76       integer np2are(nbarto)
  77       integer etapen
  78       integer listso(6), listno(9)
  79       integer nbarco, nuaret(nbarco)
  80 c
  81       double precision vap2ho(nbfop2,*)
  82 c
  83 c 0.4. ==> variables locales
  84 c
  85       integer iaux
  86 cgn      integer jaux
  87       integer nuloso
  88       integer iaux1(6)
  89       integer listns(15)
  90       integer sm, nuv
  91 c
  92 c ______________________________________________________________________
  93 c
  94 #include "impr03.h"
  95 c
  96 cgn      write(1,90002) 'listso', (listso(iaux),iaux=1,6)
  97 cgn      write(1,90002) 'listno', (listno(iaux),iaux=1,9)
  98 c
  99 c====
 100 c   Reperage des aretes entre noeud central et sommets
 101 c    . Quand une face triangulaire est coupee, etat 51/52, on doit
 102 c      regarder sucessivement les 3 aretes internes depuis les sommets
 103 c      de la face non decoupee.
 104 c      Les aretes transmises en argument sont dans l'ordre :
 105 c      . etat 51 : S4, S6, S5
 106 c      . etat 52 : S1, S2, S3
 107 c    . Quand 2 aretes sont coupees, etat 31-36, on doit regarder
 108 c      sucessivement les 6 aretes depuis chacun des sommets.
 109 c      Les aretes renvoyees par utaipe pointent d'abord sur les
 110 c      sommets de la face quadrangulaire coupee, dans cet ordre :
 111 c      . Les deux premiers sommets sont ceux qui appartiennent
 112 c        a la face triangulaire F1
 113 c      . Les 4 sommets tournent dans le sens positif, vus
 114 c        de l'exterieur
 115 c      Ensuite, on a les 2 autres sommets, en commencant par celui
 116 c      qui appartient a la face F1
 117 c
 118 c    Consequence pour la boucle 10 :
 119 c      Cas  !! Etat ! iaux !! Etat ! iaux !! Etat ! iaux
 120 c     S1-M  !!  52  !   1  !!  33  !   1  !!  36  !   1
 121 c     S2-M  !!  52  !   2  !!  31  !   1  !!  34  !   1
 122 c     S3-M  !!  52  !   3  !!  32  !   1  !!  35  !   1
 123 c     S4-M  !!  51  !   1  !!  32  !   2  !!  34  !   2
 124 c     S5-M  !!  51  !   3  !!  33  !   2  !!  35  !   2
 125 c     S6-M  !!  51  !   2  !!  31  !   2  !!  36  !   2
 126 c====
 127 c
 128 cgn      write(1,90002) 'Aretes', (nuaret(iaux),iaux=1,nbarco)
 129 c
 130       do 10 , iaux = 1 , nbarco
 131 c
 132 c====
 133 c 2. Reperage du sommet a relier
 134 c====
 135 c
 136         if ( etapen.eq.31 ) then
 137           if ( iaux.eq.1 ) then
 138             nuloso = 2
 139           else
 140             nuloso = 6
 141           endif
 142         elseif ( etapen.eq.32 ) then
 143           if ( iaux.eq.1 ) then
 144             nuloso = 3
 145           else
 146             nuloso = 4
 147           endif
 148         elseif ( etapen.eq.33 ) then
 149           if ( iaux.eq.1 ) then
 150             nuloso = 1
 151           else
 152             nuloso = 5
 153           endif
 154         elseif ( etapen.eq.34 ) then
 155           if ( iaux.eq.1 ) then
 156             nuloso = 2
 157           else
 158             nuloso = 4
 159           endif
 160         elseif ( etapen.eq.35 ) then
 161           if ( iaux.eq.1 ) then
 162             nuloso = 3
 163           else
 164             nuloso = 5
 165           endif
 166         elseif ( etapen.eq.36 ) then
 167           if ( iaux.eq.1 ) then
 168             nuloso = 1
 169           else
 170             nuloso = 6
 171           endif
 172         elseif ( etapen.eq.51 ) then
 173           if ( iaux.eq.1 ) then
 174             nuloso = 4
 175           elseif ( iaux.eq.2 ) then
 176             nuloso = 6
 177           else
 178             nuloso = 5
 179           endif
 180         else
 181           nuloso = iaux
 182         endif
 183 c
 184         listns(1) = listso(nuloso)
 185 cgn        write(1,90002) 'sommet a relier', listns(1)
 186 c
 187 c====
 188 c 3. Les sommets
 189 c    2, 3 : les 2 autres sommets de la face
 190 c    4 : le sommet semblable sur la face opposee
 191 c    5, 6 : les sommets semblables sur la face opposee
 192 c====
 193 c
 194         if ( nuloso.eq.1 ) then
 195           iaux1(1) = 3
 196           iaux1(2) = 2
 197           iaux1(3) = 4
 198           iaux1(4) = 6
 199           iaux1(5) = 5
 200         elseif ( nuloso.eq.2 ) then
 201           iaux1(1) = 1
 202           iaux1(2) = 3
 203           iaux1(3) = 5
 204           iaux1(4) = 4
 205           iaux1(5) = 6
 206         elseif ( nuloso.eq.3 ) then
 207           iaux1(1) = 2
 208           iaux1(2) = 1
 209           iaux1(3) = 6
 210           iaux1(4) = 5
 211           iaux1(5) = 4
 212         elseif ( nuloso.eq.4 ) then
 213           iaux1(1) = 6
 214           iaux1(2) = 5
 215           iaux1(3) = 1
 216           iaux1(4) = 3
 217           iaux1(5) = 2
 218         elseif ( nuloso.eq.5 ) then
 219           iaux1(1) = 4
 220           iaux1(2) = 6
 221           iaux1(3) = 2
 222           iaux1(4) = 1
 223           iaux1(5) = 3
 224         else
 225           iaux1(1) = 5
 226           iaux1(2) = 4
 227           iaux1(3) = 3
 228           iaux1(4) = 2
 229           iaux1(5) = 1
 230         endif
 231 c
 232         listns(2) = listso(iaux1(1))
 233         listns(3) = listso(iaux1(2))
 234         listns(4) = listso(iaux1(3))
 235         listns(5) = listso(iaux1(4))
 236         listns(6) = listso(iaux1(5))
 237 cgn        write(1,90002) 'listns 2-6', (listns(jaux),jaux=2,6)
 238 c
 239 c====
 240 c 4. Les noeuds des faces triangulaires
 241 c    7, 8 : les deux noeuds les plus proches, sur la face tria proche
 242 c    9 : l'autre noeud sur cette face proche
 243 c    10 : le noeud translate de cet autre noeud
 244 c    11, 12 : les deux autres noeuds sur la face opposee
 245 c====
 246 c
 247         if ( nuloso.eq.1 ) then
 248           iaux1(1) = 1
 249           iaux1(2) = 2
 250           iaux1(3) = 3
 251           iaux1(4) = 6
 252           iaux1(5) = 4
 253           iaux1(6) = 5
 254          elseif ( nuloso.eq.2 ) then
 255           iaux1(1) = 2
 256           iaux1(2) = 3
 257           iaux1(3) = 1
 258           iaux1(4) = 4
 259           iaux1(5) = 5
 260           iaux1(6) = 6
 261         elseif ( nuloso.eq.3 ) then
 262           iaux1(1) = 3
 263           iaux1(2) = 1
 264           iaux1(3) = 2
 265           iaux1(4) = 5
 266           iaux1(5) = 6
 267           iaux1(6) = 4
 268         elseif ( nuloso.eq.4 ) then
 269           iaux1(1) = 4
 270           iaux1(2) = 5
 271           iaux1(3) = 6
 272           iaux1(4) = 3
 273           iaux1(5) = 1
 274           iaux1(6) = 2
 275         elseif ( nuloso.eq.5 ) then
 276           iaux1(1) = 5
 277           iaux1(2) = 6
 278           iaux1(3) = 4
 279           iaux1(4) = 1
 280           iaux1(5) = 3
 281           iaux1(6) = 2
 282         else
 283           iaux1(1) = 6
 284           iaux1(2) = 4
 285           iaux1(3) = 5
 286           iaux1(4) = 2
 287           iaux1(5) = 3
 288           iaux1(6) = 1
 289         endif
 290 c
 291         listns( 7) = listno(iaux1(1))
 292         listns( 8) = listno(iaux1(2))
 293         listns( 9) = listno(iaux1(3))
 294         listns(10) = listno(iaux1(4))
 295         listns(11) = listno(iaux1(5))
 296         listns(12) = listno(iaux1(6))
 297 cgn      write(1,90002) 'listns 7-12', (listns(jaux),jaux=7,12)
 298 c
 299 c====
 300 c 5. Les noeuds des faces quadrangulaires
 301 c    13 : le noeud le plus proche, sur la face quadrangulaire proche
 302 c    14, 15 : le dernier noeud
 303 c====
 304 c
 305         if ( nuloso.eq.1 .or. nuloso.eq.4 ) then
 306           iaux1(1) = 7
 307           iaux1(2) = 9
 308           iaux1(3) = 8
 309          elseif ( nuloso.eq.2 .or. nuloso.eq.5 ) then
 310           iaux1(1) = 8
 311           iaux1(2) = 7
 312           iaux1(3) = 9
 313         else
 314           iaux1(1) = 9
 315           iaux1(2) = 8
 316           iaux1(3) = 7
 317         endif
 318 c
 319         listns(13) = listno(iaux1(1))
 320         listns(14) = listno(iaux1(2))
 321         listns(15) = listno(iaux1(3))
 322 cgn      write(1,90002) 'listns 13-15', (listns(jaux),jaux=13,15)
 323 c
 324 c====
 325 c 6. Interpolation
 326 c====
 327 c
 328         sm = np2are(nuaret(iaux))
 329 cgn        write(1,90002) 'sm',sm
 330 c
 331         profho(sm) = 1
 332 c
 333         do 61 , nuv = 1, nbfop2
 334 c
 335           vap2ho(nuv,sm) = unsdz * ( vap2ho(nuv,listns(9))
 336      >                             - vap2ho(nuv,listns(1)) )
 337      >                   - sts48 * ( vap2ho(nuv,listns(2))
 338      >                             + vap2ho(nuv,listns(3)) )
 339      >                   - sts36 * vap2ho(nuv,listns(4))
 340      >                   - tz144 * ( vap2ho(nuv,listns(5))
 341      >                             + vap2ho(nuv,listns(6)) )
 342      >                   + unstr * ( vap2ho(nuv,listns(7))
 343      >                             + vap2ho(nuv,listns(8)) )
 344      >                   + uns36 * vap2ho(nuv,listns(10))
 345      >                   + unsne * ( vap2ho(nuv,listns(11))
 346      >                             + vap2ho(nuv,listns(12)) )
 347      >                   + unsde * vap2ho(nuv,listns(13))
 348      >                   + unshu * ( vap2ho(nuv,listns(14))
 349      >                             + vap2ho(nuv,listns(15)) )
 350 cgn          write(1,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm)
 351    61   continue
 352 c
 353    10 continue
 354 c
 355       end