src/tool/AP_Conversion/pcs2p4.F

   1       subroutine pcs2p4 ( 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 - 4
  29 c                   -                                -            -
  30 c    D'un milieu d'arete a un autre
  31 c remarque : pcs2p4 et pcsip4 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 "fractf.h"
  60 #include "fractg.h"
  61 c
  62 c 0.2. ==> communs
  63 c
  64 #include "nombar.h"
  65 c
  66 c 0.3. ==> arguments
  67 c
  68       integer nbfop2
  69       integer profho(*)
  70       integer np2are(nbarto)
  71       integer etapen
  72       integer listso(6), listno(9)
  73       integer nbarco, nuaret(nbarco)
  74 c
  75       double precision vap2ho(nbfop2,*)
  76 c
  77 c 0.4. ==> variables locales
  78 c
  79 cgn      integer iaux
  80       integer iaux1(6)
  81       integer listns(15)
  82       integer sm, nuv
  83 c
  84 c ______________________________________________________________________
  85 c
  86 #include "impr03.h"
  87 c
  88 cgn      write(1,90002) 'listso', (listso(iaux),iaux=1,6)
  89 cgn      write(1,90002) 'listno', (listno(iaux),iaux=1,9)
  90 c
  91 cgn      write(1,90002) 'Aretes', (nuaret(iaux),iaux=1,nbarco)
  92 c
  93 c====
  94 c 2. Les 2 sommets sur l'arete oppose et les 4 autres sommets
  95 c====
  96 c
  97       if ( etapen.eq.21 ) then
  98         iaux1(1) = 6
  99         iaux1(2) = 4
 100         iaux1(3) = 5
 101         iaux1(4) = 1
 102         iaux1(5) = 2
 103         iaux1(6) = 3
 104         elseif ( etapen.eq.22 ) then
 105         iaux1(1) = 4
 106         iaux1(2) = 5
 107         iaux1(3) = 6
 108         iaux1(4) = 1
 109         iaux1(5) = 2
 110         iaux1(6) = 3
 111       elseif ( etapen.eq.23 ) then
 112         iaux1(1) = 5
 113         iaux1(2) = 6
 114         iaux1(3) = 4
 115         iaux1(4) = 1
 116         iaux1(5) = 2
 117         iaux1(6) = 3
 118       elseif ( etapen.eq.24 ) then
 119         iaux1(1) = 3
 120         iaux1(2) = 1
 121         iaux1(3) = 2
 122         iaux1(4) = 4
 123         iaux1(5) = 5
 124         iaux1(6) = 6
 125       elseif ( etapen.eq.25 ) then
 126         iaux1(1) = 1
 127         iaux1(2) = 2
 128         iaux1(3) = 3
 129         iaux1(4) = 4
 130         iaux1(5) = 5
 131         iaux1(6) = 6
 132       else
 133         iaux1(1) = 2
 134         iaux1(2) = 3
 135         iaux1(3) = 1
 136         iaux1(4) = 4
 137         iaux1(5) = 5
 138         iaux1(6) = 6
 139       endif
 140 c
 141       listns(1) = listso(iaux1(1))
 142       listns(2) = listso(iaux1(2))
 143       listns(3) = listso(iaux1(3))
 144       listns(4) = listso(iaux1(4))
 145       listns(5) = listso(iaux1(5))
 146       listns(6) = listso(iaux1(6))
 147 cgn        write(1,90002) 'listns 1-6', (listns(iaux),iaux=1,6)
 148 c
 149 c====
 150 c 3. Les noeuds
 151 c    7, 8 : les 2 noeuds sur la face triangulaire non coupee, du cote
 152 c           de l'arete de quadrangle coupee
 153 c    9 : le dernier noeud sur la face triangulaire non coupee
 154 c    10, 11, 12 : les noeuds semblables sur la face coupee
 155 c====
 156 c
 157       if ( etapen.eq.21 ) then
 158         iaux1(1) = 5
 159         iaux1(2) = 6
 160         iaux1(3) = 4
 161         iaux1(4) = 2
 162         iaux1(5) = 3
 163         iaux1(6) = 1
 164       elseif ( etapen.eq.22 ) then
 165         iaux1(1) = 6
 166         iaux1(2) = 4
 167         iaux1(3) = 5
 168         iaux1(4) = 3
 169         iaux1(5) = 1
 170         iaux1(6) = 2
 171       elseif ( etapen.eq.23 ) then
 172         iaux1(1) = 4
 173         iaux1(2) = 5
 174         iaux1(3) = 6
 175         iaux1(4) = 1
 176         iaux1(5) = 2
 177         iaux1(6) = 3
 178       elseif ( etapen.eq.24 ) then
 179         iaux1(1) = 2
 180         iaux1(2) = 3
 181         iaux1(3) = 1
 182         iaux1(4) = 5
 183         iaux1(5) = 6
 184         iaux1(6) = 4
 185       elseif ( etapen.eq.25 ) then
 186         iaux1(1) = 3
 187         iaux1(2) = 1
 188         iaux1(3) = 2
 189         iaux1(4) = 6
 190         iaux1(5) = 4
 191         iaux1(6) = 5
 192       else
 193         iaux1(1) = 1
 194         iaux1(2) = 2
 195         iaux1(3) = 3
 196         iaux1(4) = 4
 197         iaux1(5) = 4
 198         iaux1(6) = 6
 199       endif
 200 c
 201       listns( 7) = listno(iaux1(1))
 202       listns( 8) = listno(iaux1(2))
 203       listns( 9) = listno(iaux1(3))
 204       listns(10) = listno(iaux1(4))
 205       listns(11) = listno(iaux1(5))
 206       listns(12) = listno(iaux1(6))
 207 cgn      write(1,90002) 'listns 7-12', (listns(iaux),iaux=7,12)
 208 c
 209 c====
 210 c 4. Les noeuds
 211 c    13 : le noeud milieu de l'arete quadrangulaire coupee
 212 c    14, 15 : les deux autres noeuds 'quadrangle'
 213 c====
 214 c
 215       if ( etapen.eq.21 .or. etapen.eq.24 ) then
 216         iaux1(1) = 8
 217         iaux1(2) = 9
 218         iaux1(3) = 7
 219       elseif ( etapen.eq.22 .or. etapen.eq.25 ) then
 220         iaux1(1) = 9
 221         iaux1(2) = 7
 222         iaux1(3) = 8
 223       else
 224         iaux1(1) = 7
 225         iaux1(2) = 8
 226         iaux1(3) = 9
 227       endif
 228 c
 229       listns(13) = listno(iaux1(1))
 230       listns(14) = listno(iaux1(2))
 231       listns(15) = listno(iaux1(3))
 232 cgn      write(1,90002) 'listns 13-15', (listns(iaux),iaux=13,15)
 233 c
 234 c====
 235 c 5. Interpolation
 236 c====
 237 c
 238       sm = np2are(nuaret(1))
 239 cgn        write(1,90002) 'sm',sm
 240 c
 241       profho(sm) = 1
 242 c
 243       do 51 , nuv = 1, nbfop2
 244 c
 245         vap2ho(nuv,sm) = unshu * ( vap2ho(nuv,listns(7))
 246      >                           + vap2ho(nuv,listns(8))
 247      >                           - vap2ho(nuv,listns(1))
 248      >                           - vap2ho(nuv,listns(2)) )
 249      >                 + trssz * ( vap2ho(nuv,listns(10))
 250      >                           + vap2ho(nuv,listns(11))
 251      >                           + vap2ho(nuv,listns(12))
 252      >                           - vap2ho(nuv,listns(3))
 253      >                           - vap2ho(nuv,listns(4))
 254      >                           - vap2ho(nuv,listns(5))
 255      >                           - vap2ho(nuv,listns(6)) )
 256      >                 + unssz * vap2ho(nuv,listns(9))
 257      >                 + trshu * ( vap2ho(nuv,listns(13))
 258      >                           + vap2ho(nuv,listns(14))
 259      >                           + vap2ho(nuv,listns(15)) )
 260 cgn        write(1,*) 'vap2ho(nuv,',sm,') =',vap2ho(nuv,sm)
 261    51 continue
 262 c
 263       end