src/tool/AP_Conversion/pcs2h4.F

   1       subroutine pcs2h4 ( nbfop2, profho, vap2ho,
   2      >                    somare, np2are,
   3      >                    listso, listar,
   4      >                    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 - 4
  29 c                   -                            -           -
  30 c    D'un milieu d'arete a un sommet (selon 1 arete)
  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 . listso . e   .   8    . numeros globaux des sommets                .
  44 c . listar . e   .  12    . numeros globaux des aretes                 .
  45 c . areint . e   .   *    . numeros globaux des aretes internes        .
  46 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  47 c . langue . e   .    1   . langue des messages                        .
  48 c .        .     .        . 1 : francais, 2 : anglais                  .
  49 c . codret . es  .    1   . code de retour des modules                 .
  50 c .        .     .        . 0 : pas de probleme                        .
  51 c .        .     .        . 1 : probleme                               .
  52 c ______________________________________________________________________
  53 c
  54 c====
  55 c 0. declarations et dimensionnement
  56 c====
  57 c
  58 c 0.1. ==> generalites
  59 c
  60       implicit none
  61       save
  62 c
  63       character*6 nompro
  64       parameter ( nompro = 'PCS2H4' )
  65 c
  66 #include "nblang.h"
  67 c
  68 #include "fractf.h"
  69 #include "fractg.h"
  70 #include "fracth.h"
  71 c
  72 c 0.2. ==> communs
  73 c
  74 #include "envex1.h"
  75 c
  76 #include "nombar.h"
  77 c
  78 c 0.3. ==> arguments
  79 c
  80       integer nbfop2
  81       integer profho(*)
  82       integer somare(2,nbarto), np2are(nbarto)
  83       integer listso(8), listar(12)
  84       integer areint(*)
  85 c
  86       double precision vap2ho(nbfop2,*)
  87 c
  88       integer ulsort, langue, codret
  89 c
  90 c 0.4. ==> variables locales
  91 c
  92       integer iaux, jaux
  93       integer larete
  94       integer listns(20)
  95       integer sm(2), nuv
  96       integer iaux1(2), iaux2(2), iaux3(2), iaux4(2)
  97       integer jaux1(2), jaux2(2), jaux3(2), jaux4(2)
  98       integer kaux1(2), kaux2(2), kaux3(2), kaux4(2)
  99       integer laux1(2), laux2(2), laux3(2), laux4(2)
 100       integer maux1, maux2, maux3, maux4
 101       integer perm12(2)
 102 c
 103       integer nbmess
 104       parameter ( nbmess = 100 )
 105       character*80 texte(nblang,nbmess)
 106 c
 107 c 0.5. ==> initialisation
 108 c
 109       data perm12 / 2, 1 /
 110 c
 111 #include "impr03.h"
 112 c ______________________________________________________________________
 113 c
 114 #include "impr01.h"
 115 c
 116 cgn        write (ulsort,texte(langue,1)) 'Entree', nompro
 117 #ifdef _DEBUG_HOMARD_
 118       write (ulsort,90002) 'listar  1-8', (listar(iaux),iaux=1,8)
 119       write (ulsort,90002) 'listar 9-12', (listar(iaux),iaux=9,12)
 120       write (ulsort,90002) 'listso', listso
 121 #endif
 122 c
 123 c     Deux aretes partent du milieu de l'arete coupee vers un des deux
 124 c     sommets de l'arete opposee. On a donc deux interpolations a faire.
 125 c     Ce sont les indices 1 et 2 des tableaux iauxi.
 126 c
 127 cgn        write (ulsort,*) 'la', nuarlo,'-eme arete est coupee'
 128 c
 129 c====
 130 c 1. Les sommets de la face qui contient le sommet
 131 c    iaux1 : le sommet de l'arete coupee
 132 c    iaux2/3 : les deux autres sommets
 133 c    iaux4 : le sommet oppose
 134 c====
 135 c
 136 c     f1 : F3
 137       iaux1(1) = 1
 138       iaux2(1) = 4
 139       iaux3(1) = 6
 140       iaux4(1) = 7
 141 c     f2 : F4
 142       iaux1(2) = 2
 143       iaux2(2) = 3
 144       iaux3(2) = 5
 145       iaux4(2) = 8
 146 c
 147 c====
 148 c 2. Les noeuds de la face du cote du sommet oppose
 149 c    kaux1/2 : les milieux des aretes vers l'arete coupee
 150 c    kaux3/4 : les milieux des aretes vers le sommet oppose
 151 c====
 152 c
 153 c     f1 : F3
 154       kaux1(1) = 2
 155       kaux2(1) = 5
 156       kaux3(1) = 7
 157       kaux4(1) = 10
 158 c     f2 : F4
 159       kaux1(2) = 3
 160       kaux2(2) = 6
 161       kaux3(2) = 8
 162       kaux4(2) = 11
 163 c
 164 c====
 165 c 3. Les noeuds et sommets de la face opposee :
 166 c    . jauxi a le meme role que iauxi
 167 c    . lauxi a le meme role que kauxi
 168 c====
 169 c
 170       do 31 , iaux = 1 , 2
 171 c
 172         jaux1(iaux) = iaux1(perm12(iaux))
 173         jaux2(iaux) = iaux2(perm12(iaux))
 174         jaux3(iaux) = iaux3(perm12(iaux))
 175         jaux4(iaux) = iaux4(perm12(iaux))
 176 c
 177         laux1(iaux) = kaux1(perm12(iaux))
 178         laux2(iaux) = kaux2(perm12(iaux))
 179         laux3(iaux) = kaux3(perm12(iaux))
 180         laux4(iaux) = kaux4(perm12(iaux))
 181 c
 182    31 continue
 183 c
 184 c====
 185 c 4. Les noeuds milieux intermediaires
 186 c    maux1 : le milieu de l'arete coupee
 187 c    maux2/3 : les milieux des aretes paralleles a l'arete coupee
 188 c    maux4 : le milieu de l'arete oppose
 189 c====
 190 c
 191       maux1 = 1
 192       maux2 = 4
 193       maux3 = 9
 194       maux4 = 12
 195 c
 196 c====
 197 c 5. L'arete concernee : celle des deux aretes internes qui demarrent
 198 c    sur le sommet oppose
 199 c====
 200 c
 201       larete = areint(1)
 202       if ( somare(1,larete).eq.listso(iaux4(1)) ) then
 203         sm(1) = np2are(larete)
 204         sm(2) = np2are(areint(2))
 205       else
 206         sm(1) = np2are(areint(2))
 207         sm(2) = np2are(larete)
 208       endif
 209 c
 210 c====
 211 c 7. Interpolation
 212 c====
 213 c
 214       if ( codret.eq.0 ) then
 215 c
 216       do 70 , iaux = 1 , 2
 217 c
 218         profho(sm(iaux)) = 1
 219 cgn        write (ulsort,*) 'sm =',sm(iaux)
 220 c
 221         listns( 1) = listso(iaux1(iaux))
 222         listns( 2) = listso(iaux2(iaux))
 223         listns( 3) = listso(iaux3(iaux))
 224         listns( 4) = listso(iaux4(iaux))
 225         listns( 5) = listso(jaux1(iaux))
 226         listns( 6) = listso(jaux2(iaux))
 227         listns( 7) = listso(jaux3(iaux))
 228         listns( 8) = listso(jaux4(iaux))
 229         listns( 9) = np2are(listar(kaux1(iaux)))
 230         listns(10) = np2are(listar(kaux2(iaux)))
 231         listns(11) = np2are(listar(kaux3(iaux)))
 232         listns(12) = np2are(listar(kaux4(iaux)))
 233         listns(13) = np2are(listar(laux1(iaux)))
 234         listns(14) = np2are(listar(laux2(iaux)))
 235         listns(15) = np2are(listar(laux3(iaux)))
 236         listns(16) = np2are(listar(laux4(iaux)))
 237         listns(17) = np2are(listar(maux1))
 238         listns(18) = np2are(listar(maux2))
 239         listns(19) = np2are(listar(maux3))
 240         listns(20) = np2are(listar(maux4))
 241 cgn        write (ulsort,90002) 'listns  1- 8',(listns(jaux),jaux=1,8)
 242 cgn        write (ulsort,90002) 'listns  9-16',(listns(jaux),jaux=9,16)
 243 cgn        write (ulsort,90002) 'listns 17-20',(listns(jaux),jaux=17,20)
 244 cgn        write (ulsort,*) listar(kaux1(iaux)),
 245 cgn     >             listar(kaux2(iaux)),
 246 cgn     >             listar(kaux3(iaux)),
 247 cgn     >             listar(kaux4(iaux))
 248 cgn        write (ulsort,*) listar(laux1(iaux)),
 249 cgn     >             listar(laux2(iaux)),
 250 cgn     >             listar(laux3(iaux)),
 251 cgn     >             listar(laux4(iaux))
 252 c
 253         do 71, nuv = 1 , nbfop2
 254
 255 c
 256 cgn          do 711 , jaux =1 ,20
 257 cgn        write (ulsort,90014) listns(jaux), vap2ho(nuv,listns(jaux))
 258 cgn  711 continue
 259           vap2ho(nuv,sm(iaux)) =
 260      >              - nfstr2 * ( vap2ho(nuv,listns(1))
 261      >                         + vap2ho(nuv,listns(2))
 262      >                         + vap2ho(nuv,listns(3))
 263      >                         + vap2ho(nuv,listns(4)) )
 264      >              - cqstr2 * ( vap2ho(nuv,listns(5))
 265      >                         + vap2ho(nuv,listns(6))
 266      >                         + vap2ho(nuv,listns(7))
 267      >                         + vap2ho(nuv,listns(8)) )
 268      >              + trshu  * ( vap2ho(nuv,listns(9))
 269      >                         + vap2ho(nuv,listns(10))
 270      >                         + vap2ho(nuv,listns(11))
 271      >                         + vap2ho(nuv,listns(12)) )
 272      >              + unshu  * ( vap2ho(nuv,listns(13))
 273      >                         + vap2ho(nuv,listns(14))
 274      >                         + vap2ho(nuv,listns(15))
 275      >                         + vap2ho(nuv,listns(16)) )
 276      >              + trssz  * ( vap2ho(nuv,listns(17))
 277      >                         + vap2ho(nuv,listns(18))
 278      >                         + vap2ho(nuv,listns(19))
 279      >                         + vap2ho(nuv,listns(20)) )
 280 c
 281 cgn        write (ulsort,*) 'vap2ho(nuv,',sm(iaux),') =',vap2ho(nuv,sm(iaux))
 282    71 continue
 283 c
 284    70 continue
 285 c
 286       endif
 287 c
 288 c====
 289 c 8. La fin
 290 c====
 291 c
 292       if ( codret.ne.0 ) then
 293 c
 294 #include "envex2.h"
 295 c
 296       write (ulsort,texte(langue,1)) 'Sortie', nompro
 297       write (ulsort,texte(langue,2)) codret
 298 c
 299       endif
 300 c
 301 #ifdef _DEBUG_HOMARD_
 302       write (ulsort,texte(langue,1)) 'Sortie', nompro
 303       call dmflsh (iaux)
 304 #endif
 305 c
 306       end