src/tool/AP_Conversion/pcs1he.F

   1       subroutine pcs1he ( nbfop1, profho,
   2      >                    somare,
   3      >                    aretri, arequa,
   4      >                    tritet, cotrte, aretet,
   5      >                    quahex, coquhe, arehex,
   6      >                    filhex, hethex, fhpyte,
   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 HExaedres
  32 c                   -                                      --
  33 c remarque : on devrait optimiser cela car si l'hexaedre 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 . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  47 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  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 . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  51 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  52 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  53 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  54 c . filhex . e   . nbheto . premier fils des hexaedres                 .
  55 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  56 c . fhpyte . e   .2*nbheco. fhpyte(1,j) = numero de la 1ere pyramide   .
  57 c .        .     .        . fille de l'hexaedre k tel que filhex(k) =-j.
  58 c .        .     .        . fhpyte(2,j) = numero du 1er tetraedre      .
  59 c .        .     .        . fils de l'hexaedre k tel que filhex(k) = -j.
  60 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  61 c . cofapy . e   .nbpycf*5. codes des 5 faces des pyramides            .
  62 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  63 c . vap1ho . es  . nbfop1*. variables p1 numerotation homard           .
  64 c .        .     . nbnoto .                                            .
  65 c ______________________________________________________________________
  66 c
  67 c====
  68 c 0. declarations et dimensionnement
  69 c====
  70 c
  71 c 0.1. ==> generalites
  72 c
  73       implicit none
  74       save
  75 c
  76 #include "fractf.h"
  77 c
  78 c 0.2. ==> communs
  79 c
  80 #include "nombar.h"
  81 #include "nombno.h"
  82 #include "nombtr.h"
  83 #include "nombqu.h"
  84 #include "nombte.h"
  85 #include "nombpy.h"
  86 #include "nombhe.h"
  87 #include "hexcf0.h"
  88 c
  89 c 0.3. ==> arguments
  90 c
  91       integer nbfop1
  92       integer profho(nbnoto)
  93       integer somare(2,nbarto)
  94       integer aretri(nbtrto,3)
  95       integer arequa(nbquto,4)
  96       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
  97       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
  98       integer filhex(nbheto), hethex(nbheto)
  99       integer fhpyte(2,nbheco)
 100       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 101 c
 102       double precision vap1ho(nbfop1,*)
 103 c
 104 c 0.4. ==> variables locales
 105 c
 106       integer lehexa, lehex0
 107       integer listar(12), listso(8)
 108       integer etahex
 109       integer sm, nuv
 110       integer iaux
 111 c
 112       double precision daux
 113 c ______________________________________________________________________
 114 c
 115 #include "impr03.h"
 116 c
 117 c====
 118 c 1. interpolation p1 pour les hexaedres qui viennent d'etre decoupes
 119 c    avec creation d'un noeud central. Ce noeud est au barycentre
 120 c    des 8 sommets de l'hexaedre pere. Donc on prend la moyenne de la
 121 c    fonction sur ces 8 noeuds.
 122 c====
 123 c
 124       if ( nbfop1.ne.0 ) then
 125 c
 126       do 10 , lehex0 = 1, nbheto
 127 c
 128           lehexa = lehex0
 129 c
 130         etahex = mod(hethex(lehexa),1000)
 131 cgn          write(6,90015) 'hexa',lehexa,' => etat, binaire, chnp1',
 132 cgn     >       hethex(lehexa), chbiet(etahex), chnp1(chbiet(etahex))
 133 cgn          write(6,*) (quahex(lehexa,iaux),iaux=1,6)
 134 cgn          write(6,*) (coquhe(lehexa,iaux),iaux=1,6)
 135 c
 136         if ( chnp1(chbiet(etahex)).gt.0 ) then
 137 c
 138 c         les aretes et les sommets de l'hexaedre
 139 c
 140           call utashe ( lehexa,
 141      >                  nbquto, nbhecf, nbheca,
 142      >                  somare, arequa,
 143      >                  quahex, coquhe, arehex,
 144      >                  listar, listso )
 145 cgn          write(6,*) listso
 146 c
 147 c         tous les sommets doivent etre dans le profil
 148 c
 149           do 102 , iaux = 1 , 8
 150             if ( profho(listso(iaux)).ne.1 ) then
 151               goto 10
 152             endif
 153   102     continue
 154 c
 155 c         recherche du noeud central
 156 c
 157           iaux = lehexa
 158           call utnmhe ( iaux, sm,
 159      >                  somare, aretri, arequa,
 160      >                  tritet, cotrte, aretet,
 161      >                  quahex, coquhe, filhex, fhpyte,
 162      >                  facpyr, cofapy, arepyr )
 163 cgn          write(6,*) 'sm', sm
 164 c
 165 c         le noeud central est a ajouter dans le profil
 166 c
 167           profho(sm) = 1
 168 c
 169 c         interpolation = 1/8 (u1+u2+u3...u8)
 170 c
 171           do 103 , nuv = 1, nbfop1
 172 c
 173             daux = 0.d0
 174             do 1031 , iaux = 1 , 8
 175               daux = daux + vap1ho(nuv,listso(iaux))
 176  1031       continue
 177             vap1ho(nuv,sm) = unshu * daux
 178 c
 179   103     continue
 180 c
 181         endif
 182 c
 183    10 continue
 184 c
 185       endif
 186 c
 187       end