src/tool/Utilitaire/utvhex.F

   1       subroutine utvhex ( lehexa, volume,
   2      >                    coonoe, somare, arequa,
   3      >                    quahex, coquhe, arehex )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c     UTilitaire : Volume d'un HEXaedre
  25 c     --           -           ---
  26 c ______________________________________________________________________
  27 c .        .     .        .                                            .
  28 c .  nom   . e/s . taille .           description                      .
  29 c .____________________________________________________________________.
  30 c . lehexa . e   .  1     . numero de l'hexaedre a examiner            .
  31 c . volume .  s  .  1     . volume                                     .
  32 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  33 c .        .     . * sdim .                                            .
  34 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  35 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  36 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  37 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  38 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  39 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  40 c ______________________________________________________________________
  41 c
  42 c====
  43 c 0. declarations et dimensionnement
  44 c====
  45 c
  46 c 0.1. ==> generalites
  47 c
  48       implicit none
  49       save
  50 c
  51 #include "fractc.h"
  52 #include "fractf.h"
  53 c
  54 c 0.2. ==> communs
  55 c
  56 #include "nombno.h"
  57 #include "nombar.h"
  58 #include "nombqu.h"
  59 #include "nombhe.h"
  60 c
  61 c 0.3. ==> arguments
  62 c
  63       double precision volume
  64       double precision coonoe(nbnoto,3)
  65 c
  66       integer lehexa
  67       integer somare(2,nbarto)
  68       integer arequa(nbquto,4)
  69       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
  70 c
  71 c 0.4. ==> variables locales
  72 c
  73       integer iaux
  74       integer listar(12), listso(8)
  75       integer s1, s2, s3, s4, s5, s6, s7,s8
  76 c
  77       double precision of1(3),of2(3),of3(3),of4(3),of5(3),of6(3)
  78       double precision centr(3), qual(24), volu(24)
  79 c
  80 c====
  81 c 1. les aretes et les sommets
  82 c====
  83 c
  84       call utashe ( lehexa,
  85      >              nbquto, nbhecf, nbheca,
  86      >              somare, arequa,
  87      >              quahex, coquhe, arehex,
  88      >              listar, listso )
  89 c
  90       s1 = listso(1)
  91       s2 = listso(2)
  92       s3 = listso(3)
  93       s4 = listso(4)
  94       s5 = listso(5)
  95       s6 = listso(6)
  96       s7 = listso(7)
  97       s8 = listso(8)
  98 c
  99 c====
 100 c 2. les points caracteristiques
 101 c====
 102 c     Le centre de l'hexaedre
 103       centr(1) = unshu*(coonoe(s1,1)+coonoe(s2,1)
 104      >         + coonoe(s3,1)+coonoe(s4,1)+coonoe(s5,1)
 105      >         + coonoe(s6,1)+coonoe(s7,1)+coonoe(s8,1) )
 106       centr(2) = unshu*(coonoe(s1,2)+coonoe(s2,2)
 107      >         + coonoe(s3,2)+coonoe(s4,2)+coonoe(s5,2)
 108      >         + coonoe(s6,2)+coonoe(s7,2)+coonoe(s8,2) )
 109       centr(3) = unshu*(coonoe(s1,3)+coonoe(s2,3)
 110      >         + coonoe(s3,3)+coonoe(s4,3)+coonoe(s5,3)
 111      >         + coonoe(s6,3)+coonoe(s7,3)+coonoe(s8,3) )
 112 c     Le centre de la face 1
 113       of1(1) = unsqu*(coonoe(s1,1)+coonoe(s2,1)
 114      >       +        coonoe(s3,1)+coonoe(s4,1))
 115       of1(2) = unsqu*(coonoe(s1,2)+coonoe(s2,2)
 116      >       +        coonoe(s3,2)+coonoe(s4,2))
 117       of1(3) = unsqu*(coonoe(s1,3)+coonoe(s2,3)
 118      >       +        coonoe(s3,3)+coonoe(s4,3))
 119 c     Le centre de la face 2
 120       of2(1) = unsqu*(coonoe(s1,1)+coonoe(s2,1)
 121      >       +        coonoe(s5,1)+coonoe(s6,1))
 122       of2(2) = unsqu*(coonoe(s1,2)+coonoe(s2,2)
 123      >       +        coonoe(s5,2)+coonoe(s6,2))
 124       of2(3) = unsqu*(coonoe(s1,3)+coonoe(s2,3)
 125      >       +        coonoe(s5,3)+coonoe(s6,3))
 126 c     Le centre de la face 3
 127       of3(1) = unsqu*(coonoe(s1,1)+coonoe(s4,1)
 128      >       +        coonoe(s6,1)+coonoe(s7,1))
 129       of3(2) = unsqu*(coonoe(s1,2)+coonoe(s4,2)
 130      >       +        coonoe(s6,2)+coonoe(s7,2))
 131       of3(3) = unsqu*(coonoe(s1,3)+coonoe(s4,3)
 132      >       +        coonoe(s6,3)+coonoe(s7,3))
 133 c     Le centre de la face 4
 134       of4(1) = unsqu*(coonoe(s2,1)+coonoe(s3,1)
 135      >       +        coonoe(s5,1)+coonoe(s8,1))
 136       of4(2) = unsqu*(coonoe(s2,2)+coonoe(s3,2)
 137      >       +        coonoe(s5,2)+coonoe(s8,2))
 138       of4(3) = unsqu*(coonoe(s2,3)+coonoe(s3,3)
 139      >       +        coonoe(s5,3)+coonoe(s8,3))
 140 c     Le centre de la face 5
 141       of5(1) = unsqu*(coonoe(s3,1)+coonoe(s4,1)
 142      >       +        coonoe(s7,1)+coonoe(s8,1))
 143       of5(2) = unsqu*(coonoe(s3,2)+coonoe(s4,2)
 144      >       +        coonoe(s7,2)+coonoe(s8,2))
 145       of5(3) = unsqu*(coonoe(s3,3)+coonoe(s4,3)
 146      >       +        coonoe(s7,3)+coonoe(s8,3))
 147 c     Le centre de la face 6
 148       of6(1) = unsqu*(coonoe(s5,1)+coonoe(s6,1)
 149      >       +        coonoe(s7,1)+coonoe(s8,1))
 150       of6(2) = unsqu*(coonoe(s5,2)+coonoe(s6,2)
 151      >       +        coonoe(s7,2)+coonoe(s8,2))
 152       of6(3) = unsqu*(coonoe(s5,3)+coonoe(s6,3)
 153      >       +        coonoe(s7,3)+coonoe(s8,3))
 154 c
 155 c====
 156 c 3. volume et qualite des tetraedres
 157 c====
 158 c
 159 c     tetra touchant la face 1
 160       call utqte2 ( qual( 1), volu( 1), coonoe, s1, s2, centr, of1 )
 161       call utqte2 ( qual( 2), volu( 2), coonoe, s2, s3, centr, of1 )
 162       call utqte2 ( qual( 3), volu( 3), coonoe, s3, s4, centr, of1 )
 163       call utqte2 ( qual( 4), volu( 4), coonoe, s1, s4, centr, of1 )
 164 c     tetra touchant la face 2
 165       call utqte2 ( qual( 5), volu( 5), coonoe, s1, s2, centr, of2 )
 166       call utqte2 ( qual( 6), volu( 6), coonoe, s2, s5, centr, of2 )
 167       call utqte2 ( qual( 7), volu( 7), coonoe, s5, s6, centr, of2 )
 168       call utqte2 ( qual( 8), volu( 8), coonoe, s1, s6, centr, of2 )
 169 c     tetra touchant la face 3
 170       call utqte2 ( qual( 9), volu( 9), coonoe, s1, s4, centr, of3 )
 171       call utqte2 ( qual(10), volu(10), coonoe, s4, s7, centr, of3 )
 172       call utqte2 ( qual(11), volu(11), coonoe, s6, s7, centr, of3 )
 173       call utqte2 ( qual(12), volu(12), coonoe, s1, s6, centr, of3 )
 174 c     tetra touchant la face 4
 175       call utqte2 ( qual(13), volu(13), coonoe, s2, s3, centr, of4 )
 176       call utqte2 ( qual(14), volu(14), coonoe, s3, s8, centr, of4 )
 177       call utqte2 ( qual(15), volu(15), coonoe, s5, s8, centr, of4 )
 178       call utqte2 ( qual(16), volu(16), coonoe, s2, s5, centr, of4 )
 179 c     tetra touchant la face 5
 180       call utqte2 ( qual(17), volu(17), coonoe, s3, s4, centr, of5 )
 181       call utqte2 ( qual(18), volu(18), coonoe, s4, s7, centr, of5 )
 182       call utqte2 ( qual(19), volu(19), coonoe, s7, s8, centr, of5 )
 183       call utqte2 ( qual(20), volu(20), coonoe, s3, s8, centr, of5 )
 184 c     tetra touchant la face 6
 185       call utqte2 ( qual(21), volu(21), coonoe, s5, s6, centr, of6 )
 186       call utqte2 ( qual(22), volu(22), coonoe, s6, s7, centr, of6 )
 187       call utqte2 ( qual(23), volu(23), coonoe, s7, s8, centr, of6 )
 188       call utqte2 ( qual(24), volu(24), coonoe, s5, s8, centr, of6 )
 189 c
 190       volume = 0.d0
 191       do 10 , iaux = 1 , 24
 192         volume = volume + volu(iaux)
 193    10 continue
 194 c
 195       end