src/tool/AP_Conversion/pcs1pe.F

   1       subroutine pcs1pe ( nbfop1, profho,
   2      >                    somare,
   3      >                    aretri, arequa,
   4      >                    tritet, cotrte,
   5      >                    facpen, cofape, arepen,
   6      >                    filpen, hetpen, fppyte,
   7      >                    facpyr, cofapy, arepyr,
   8      >                    vap1ho )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    aPres adaptation - Conversion de Solution -
  30 c     -                 -             -
  31 c    interpolation p1 sur les noeuds lors du decoupage des PEntaedres
  32 c                   -                                      --
  33 c remarque : on devrait optimiser cela car si le pentaedre etait dans
  34 c            un etat de decoupage avec presence de noeud central, on
  35 c            recalcule une valeur qui est deja presente
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . nbfop1 . e   .    1   . nombre de fonctions P1                     .
  41 c . profho . es  .   *    . pour chaque entite en numerotation homard :.
  42 c .        .     .        . 0 : l'entite est absente du profil         .
  43 c .        .     .        . 1 : l'entite est presente dans le profil   .
  44 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  45 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  46 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  47 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  48 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  49 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  50 c . facpen . e   .nbpecf*5. numeros des faces des pentaedres           .
  51 c . cofape . e   .nbpecf*5. codes des faces des pentaedres             .
  52 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  53 c . filpen . e   . nbpeto . premier fils des pentaedres                .
  54 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  55 c . fppyte . e   .2*nbpeco. fppyte(1,j) = numero de la 1ere pyramide   .
  56 c .        .     .        . fille du pentaedre k tel que filpen(k) =-j .
  57 c .        .     .        . fppyte(2,j) = numero du 1er tetraedre      .
  58 c .        .     .        . fils du pentaedre k tel que filpen(k) = -j .
  59 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  60 c . cofapy . e   .nbpycf*5. codes des 5 faces des pyramides            .
  61 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  62 c . vap1ho . es  . nbfop1*. variables p1 numerotation homard           .
  63 c .        .     . nbnoto .                                            .
  64 c ______________________________________________________________________
  65 c
  66 c====
  67 c 0. declarations et dimensionnement
  68 c====
  69 c
  70 c 0.1. ==> generalites
  71 c
  72       implicit none
  73       save
  74 c
  75 #include "fracte.h"
  76 c
  77 c 0.2. ==> communs
  78 c
  79 #include "nombar.h"
  80 #include "nombno.h"
  81 #include "nombtr.h"
  82 #include "nombqu.h"
  83 #include "nombte.h"
  84 #include "nombpy.h"
  85 #include "nombpe.h"
  86 c
  87 c 0.3. ==> arguments
  88 c
  89       integer nbfop1
  90       integer profho(nbnoto)
  91       integer somare(2,nbarto)
  92       integer aretri(nbtrto,3)
  93       integer arequa(nbquto,4)
  94       integer tritet(nbtecf,4), cotrte(nbtecf,4)
  95       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
  96       integer hetpen(nbpeto), filpen(nbpeto)
  97       integer fppyte(2,nbpeco)
  98       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
  99 c
 100       double precision vap1ho(nbfop1,*)
 101 c
 102 c 0.4. ==> variables locales
 103 c
 104       integer lepent, lepen0
 105       integer listar(9), listso(6)
 106       integer etapen
 107       integer sm, nuv
 108       integer iaux
 109 c
 110       double precision daux
 111 c ______________________________________________________________________
 112 c
 113 c====
 114 c 1. interpolation p1 pour les pentaedres qui viennent d'etre decoupes
 115 c    avec creation d'un noeud central. Ce noeud est au barycentre
 116 c    des 6 sommets du pentaedre pere. Donc on prend la moyenne de la
 117 c    fonction sur ces 6 noeuds.
 118 c====
 119 c
 120       if ( nbfop1.ne.0 ) then
 121 c
 122       do 10 , lepen0 = 1, nbpeto
 123 c
 124         lepent = lepen0
 125 c
 126         etapen = mod(hetpen(lepent),100)
 127 cgn         if ( etapen.gt.0 .and. etapen.ne.80 ) then
 128 cgn          write(6,*) lepent,hetpen(lepent)
 129 cgn          endif
 130 cgn          write(6,*) lepent,hetpen(lepent)
 131 cgn          write(6,*) (facpen(lepent,iaux),iaux=1,5)
 132 cgn          write(6,*) (cofape(lepent,iaux),iaux=1,5)
 133 c
 134         if ( ( etapen.ge.31 .and. etapen.le.36 ) .or.
 135      >       ( etapen.ge.51 .and. etapen.le.52 ) ) then
 136 cgn          write(6,*) lepent,hetpen(lepent)
 137 c
 138 c         les aretes et les sommets du pentaedre
 139 c
 140           call utaspe ( lepent,
 141      >                  nbquto, nbpecf, nbpeca,
 142      >                  somare, arequa,
 143      >                  facpen, cofape, arepen,
 144      >                  listar, listso )
 145 cgn          write(6,*) listso
 146 c
 147 c         tous les noeuds doivent etre dans le profil
 148 c
 149           do 101 , iaux = 1 , 6
 150             if ( profho(listso(iaux)).ne.1 ) then
 151               goto 10
 152             endif
 153   101     continue
 154 c
 155 c         recherche du noeud central
 156 c
 157           iaux = lepent
 158           call utnmpe ( iaux, sm,
 159      >                  somare, aretri, arequa,
 160      >                  tritet, cotrte,
 161      >                  facpen, cofape, filpen, fppyte,
 162      >                  facpyr, cofapy )
 163 c
 164 c         le noeud central est a ajouter dans le profil
 165 c
 166           profho(sm) = 1
 167 c
 168 c         interpolation = 1/6 (u1+u2+u3...u6)
 169 c
 170           do 102 , nuv = 1, nbfop1
 171 c
 172             daux = 0.d0
 173             do 103 , iaux = 1 , 6
 174               daux = daux + vap1ho(nuv,listso(iaux))
 175   103       continue
 176             vap1ho(nuv,sm) = unssix * daux
 177 c
 178   102     continue
 179 c
 180         endif
 181 c
 182    10 continue
 183 c
 184       endif
 185 c
 186       end