src/tool/AP_Conversion/pcs2p2.F

   1       subroutine pcs2p2 ( 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 - 2
  29 c                   -                                -            -
  30 c    Du centre aux milieux d'aretes
  31 c remarque : pcs2p2 et pcsip2 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 "fractf.h"
  61 #include "fractg.h"
  62 #include "fractl.h"
  63 #include "fractm.h"
  64 #include "fractn.h"
  65 c
  66 c 0.2. ==> communs
  67 c
  68 #include "nombar.h"
  69 c
  70 c 0.3. ==> arguments
  71 c
  72       integer nbfop2
  73       integer profho(*)
  74       integer np2are(nbarto)
  75       integer etapen
  76       integer listso(6), listno(9)
  77       integer nbarco, nuaret(nbarco)
  78 c
  79       double precision vap2ho(nbfop2,*)
  80 c
  81 c 0.4. ==> variables locales
  82 c
  83       integer iaux
  84 cgn      integer jaux
  85       integer nulono
  86       integer iaux1(6)
  87       integer listns(15)
  88       integer sm, nuv
  89 c
  90 c ______________________________________________________________________
  91 c
  92 #include "impr03.h"
  93 c
  94 cgn      write(1,90002) 'listso', (listso(iaux),iaux=1,6)
  95 cgn      write(1,90002) 'listno', (listno(iaux),iaux=1,9)
  96 c
  97 c====
  98 c   Reperage des aretes entre noeud central et noeud d'une arete coupee
  99 c    . Quand une face triangulaire est coupee, etat 51/52, on doit
 100 c      regarder sucessivement les 3 aretes internes depuis les milieux
 101 c      des aretes de cette face.
 102 c      Les aretes transmises en argument sont dans l'ordre :
 103 c      . etat 51 : N1, N2, N3
 104 c      . etat 52 : N4, N6, N5
 105 c    . Quand 2 aretes sont coupees, etat 31-36, on doit regarder
 106 c      sucessivement les 2 aretes depuis chacun des milieux.
 107 c      Les aretes renvoyees par utaipe pointent d'abord sur le noeud
 108 c      de la face F1, puis celui de la face F2
 109 c
 110 c    Consequence pour la boucle 10 :
 111 c      Cas  !! Etat ! iaux !! Etat ! iaux !! Etat ! iaux
 112 c     N1-M  !!  51  !   1  !!  31  !   1  !!  34  !   1
 113 c     N2-M  !!  51  !   2  !!  32  !   1  !!  35  !   1
 114 c     N3-M  !!  51  !   3  !!  33  !   1  !!  36  !   1
 115 c     N4-M  !!  52  !   1  !!  33  !   2  !!  35  !   2
 116 c     N5-M  !!  52  !   3  !!  31  !   2  !!  36  !   2
 117 c     N6-M  !!  52  !   2  !!  32  !   2  !!  34  !   2
 118 c====
 119 c
 120 cgn      write(1,90002) 'Aretes', (nuaret(iaux),iaux=1,nbarco)
 121 c
 122       do 10 , iaux = 1 , nbarco
 123 c
 124 c====
 125 c 2. Reperage du noeud milieu a relier
 126 c====
 127 c
 128         if ( etapen.eq.31 ) then
 129           if ( iaux.eq.1 ) then
 130             nulono = 1
 131           else
 132             nulono = 5
 133           endif
 134         elseif ( etapen.eq.32 ) then
 135           if ( iaux.eq.1 ) then
 136             nulono = 2
 137           else
 138             nulono = 6
 139           endif
 140         elseif ( etapen.eq.33 ) then
 141           if ( iaux.eq.1 ) then
 142             nulono = 3
 143           else
 144             nulono = 4
 145           endif
 146         elseif ( etapen.eq.34 ) then
 147           if ( iaux.eq.1 ) then
 148             nulono = 1
 149           else
 150             nulono = 6
 151           endif
 152         elseif ( etapen.eq.35 ) then
 153           if ( iaux.eq.1 ) then
 154             nulono = 2
 155           else
 156             nulono = 4
 157           endif
 158         elseif ( etapen.eq.36 ) then
 159           if ( iaux.eq.1 ) then
 160             nulono = 3
 161           else
 162             nulono = 2
 163           endif
 164         elseif ( etapen.eq.51 ) then
 165           nulono = iaux
 166         else
 167           if ( iaux.eq.1 ) then
 168             nulono = 4
 169           elseif ( iaux.eq.2 ) then
 170             nulono = 6
 171           else
 172             nulono = 5
 173           endif
 174         endif
 175 c
 176         listns(7) = listno(nulono)
 177 cgn        write(1,90002) 'noeud de l''arete coupee', listns(7)
 178 c
 179 c====
 180 c 3. Les sommets
 181 c    1, 2 : les sommets de l'arete coupee
 182 c    3 : le 3eme sommet de la face
 183 c    4, 5, 6 : les sommets semblables sur la face opposee
 184 c====
 185 c
 186         if ( nulono.eq.1 ) then
 187           iaux1(1) = 1
 188           iaux1(2) = 3
 189           iaux1(3) = 2
 190           iaux1(4) = 4
 191           iaux1(5) = 6
 192           iaux1(6) = 5
 193         elseif ( nulono.eq.2 ) then
 194           iaux1(1) = 2
 195           iaux1(2) = 1
 196           iaux1(3) = 3
 197           iaux1(4) = 5
 198           iaux1(5) = 4
 199           iaux1(6) = 6
 200         elseif ( nulono.eq.3 ) then
 201           iaux1(1) = 3
 202           iaux1(2) = 2
 203           iaux1(3) = 1
 204           iaux1(4) = 6
 205           iaux1(5) = 5
 206           iaux1(6) = 4
 207         elseif ( nulono.eq.4 ) then
 208           iaux1(1) = 4
 209           iaux1(2) = 6
 210           iaux1(3) = 5
 211           iaux1(4) = 1
 212           iaux1(5) = 3
 213           iaux1(6) = 2
 214         elseif ( nulono.eq.5 ) then
 215           iaux1(1) = 5
 216           iaux1(2) = 4
 217           iaux1(3) = 6
 218           iaux1(4) = 2
 219           iaux1(5) = 1
 220           iaux1(6) = 3
 221         else
 222           iaux1(1) = 6
 223           iaux1(2) = 5
 224           iaux1(3) = 4
 225           iaux1(4) = 3
 226           iaux1(5) = 2
 227           iaux1(6) = 1
 228         endif
 229 c
 230         listns(1) = listso(iaux1(1))
 231         listns(2) = listso(iaux1(3))
 232         listns(3) = listso(iaux1(2))
 233         listns(4) = listso(iaux1(4))
 234         listns(5) = listso(iaux1(6))
 235         listns(6) = listso(iaux1(5))
 236 cgn        write(1,90002) 'listns 1-6', (listns(jaux),jaux=1,6)
 237 c
 238 c====
 239 c 4. Les noeuds des faces triangulaires
 240 c    8, 9 : les deux autres noeuds sur la face de l'arete coupee
 241 c    10 : le noeud semblable sur la face opposee
 242 c    11, 12 : les deux autres noeuds sur la face opposee
 243 c====
 244 c
 245         if ( nulono.eq.1 ) then
 246           iaux1(1) = 2
 247           iaux1(2) = 3
 248           iaux1(3) = 4
 249           iaux1(4) = 5
 250           iaux1(5) = 6
 251          elseif ( nulono.eq.2 ) then
 252           iaux1(1) = 3
 253           iaux1(2) = 1
 254           iaux1(3) = 5
 255           iaux1(4) = 6
 256           iaux1(5) = 4
 257         elseif ( nulono.eq.3 ) then
 258           iaux1(1) = 1
 259           iaux1(2) = 2
 260           iaux1(3) = 6
 261           iaux1(4) = 4
 262           iaux1(5) = 5
 263         elseif ( nulono.eq.4 ) then
 264           iaux1(1) = 5
 265           iaux1(2) = 6
 266           iaux1(3) = 1
 267           iaux1(4) = 2
 268           iaux1(5) = 3
 269         elseif ( nulono.eq.5 ) then
 270           iaux1(1) = 6
 271           iaux1(2) = 4
 272           iaux1(3) = 2
 273           iaux1(4) = 3
 274           iaux1(5) = 1
 275         else
 276           iaux1(1) = 4
 277           iaux1(2) = 5
 278           iaux1(3) = 3
 279           iaux1(4) = 1
 280           iaux1(5) = 2
 281         endif
 282 c
 283         listns( 8) = listno(iaux1(1))
 284         listns( 9) = listno(iaux1(2))
 285         listns(10) = listno(iaux1(3))
 286         listns(11) = listno(iaux1(4))
 287         listns(12) = listno(iaux1(5))
 288 cgn      write(1,90002) 'listns 8-12', (listns(jaux),jaux=8,12)
 289 c
 290 c====
 291 c 5. Les noeuds des faces quadrangulaires
 292 c    13, 14 : les noeuds du cote de l'arete coupee
 293 c    15 : le dernier noeud
 294 c====
 295 c
 296         if ( nulono.eq.1 .or. nulono.eq.4 ) then
 297           iaux1(1) = 7
 298           iaux1(2) = 9
 299           iaux1(3) = 8
 300          elseif ( nulono.eq.2 .or. nulono.eq.5 ) then
 301           iaux1(1) = 8
 302           iaux1(2) = 7
 303           iaux1(3) = 9
 304         else
 305           iaux1(1) = 9
 306           iaux1(2) = 8
 307           iaux1(3) = 7
 308         endif
 309 c
 310         listns(13) = listno(iaux1(1))
 311         listns(14) = listno(iaux1(2))
 312         listns(15) = listno(iaux1(3))
 313 cgn      write(1,90002) 'listns 13-15', (listns(jaux),jaux=13,15)
 314 c
 315 c====
 316 c 6. Interpolation
 317 c====
 318 c
 319         sm = np2are(nuaret(iaux))
 320 cgn        write(1,90002) 'sm',sm
 321 c
 322         profho(sm) = 1
 323 c
 324         do 61 , nuv = 1, nbfop2
 325 c
 326 cgn        write(1,*) 'vap2ho=',(vap2ho(nuv,listns(jaux)),jaux=1,15)
 327           vap2ho(nuv,sm) = cqs24 * ( vap2ho(nuv,listns(8))
 328      >                             + vap2ho(nuv,listns(9))
 329      >                             - vap2ho(nuv,listns(1))
 330      >                             - vap2ho(nuv,listns(2)) )
 331      >                   - sts48 * vap2ho(nuv,listns(3))
 332      >                   + vc144 * ( vap2ho(nuv,listns(10))
 333      >                             - vap2ho(nuv,listns(4))
 334      >                             - vap2ho(nuv,listns(5)) )
 335      >                   - tz144 * vap2ho(nuv,listns(6))
 336      >                   + vcs48 * vap2ho(nuv,listns(7))
 337      >                   + cqs72 * ( vap2ho(nuv,listns(11))
 338      >                             + vap2ho(nuv,listns(12)) )
 339      >                   + cqssz * ( vap2ho(nuv,listns(13))
 340      >                             + vap2ho(nuv,listns(14)) )
 341      >                   + unshu * vap2ho(nuv,listns(15))
 342 cgn        write(1,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm)
 343    61   continue
 344 c
 345    10 continue
 346 c
 347       end