src/tool/Utilitaire/utqhex.F

   1       subroutine utqhex ( lehexa, qualit, qualij, 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 : Qualite d'un HEXaedre
  25 c     --           -            ---
  26 c ______________________________________________________________________
  27 c
  28 c     . max de la qualite des tetraedres inclus
  29 c     . Jacobien normalise
  30 c ______________________________________________________________________
  31 c .        .     .        .                                            .
  32 c .  nom   . e/s . taille .           description                      .
  33 c .____________________________________________________________________.
  34 c . lehexa . e   .  1     . numero de l'hexaedre a examiner            .
  35 c . qualit .  s  .  1     . qualite des tetraedres inclus              .
  36 c . qualij .  s  .  1     . qualite par le jacobien normalise          .
  37 c . volume .  s  .  1     . volume                                     .
  38 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  39 c .        .     . * sdim .                                            .
  40 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  41 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  42 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  43 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  44 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  45 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  46 c ______________________________________________________________________
  47 c
  48 c====
  49 c 0. declarations et dimensionnement
  50 c====
  51 c
  52 c 0.1. ==> generalites
  53 c
  54       implicit none
  55       save
  56 c
  57 #include "fractc.h"
  58 #include "fractf.h"
  59 c
  60 c 0.2. ==> communs
  61 c
  62 #include "nombno.h"
  63 #include "nombar.h"
  64 #include "nombqu.h"
  65 #include "nombhe.h"
  66 c
  67 c 0.3. ==> arguments
  68 c
  69       double precision qualit, qualij, volume
  70       double precision coonoe(nbnoto,3)
  71 c
  72       integer lehexa
  73       integer somare(2,nbarto)
  74       integer arequa(nbquto,4)
  75       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
  76 c
  77 c 0.4. ==> variables locales
  78 c
  79       integer iaux
  80       integer aresom(0:3,8)
  81       integer listar(12), listso(8)
  82       integer s1, s2, s3, s4, s5, s6, s7,s8
  83 c
  84       double precision daux
  85       double precision of1(3),of2(3),of3(3),of4(3),of5(3),of6(3)
  86       double precision centr(3), qual(24), volu(24)
  87 c
  88 c====
  89 c 1. les aretes et les sommets
  90 c====
  91 c
  92       call utashe ( lehexa,
  93      >              nbquto, nbhecf, nbheca,
  94      >              somare, arequa,
  95      >              quahex, coquhe, arehex,
  96      >              listar, listso )
  97 c
  98       s1 = listso(1)
  99       s2 = listso(2)
 100       s3 = listso(3)
 101       s4 = listso(4)
 102       s5 = listso(5)
 103       s6 = listso(6)
 104       s7 = listso(7)
 105       s8 = listso(8)
 106 c
 107 c====
 108 c 2. les points caracteristiques
 109 c====
 110 c     Le centre de l'hexaedre
 111       centr(1) = unshu*(coonoe(s1,1)+coonoe(s2,1)
 112      >         + coonoe(s3,1)+coonoe(s4,1)+coonoe(s5,1)
 113      >         + coonoe(s6,1)+coonoe(s7,1)+coonoe(s8,1) )
 114       centr(2) = unshu*(coonoe(s1,2)+coonoe(s2,2)
 115      >         + coonoe(s3,2)+coonoe(s4,2)+coonoe(s5,2)
 116      >         + coonoe(s6,2)+coonoe(s7,2)+coonoe(s8,2) )
 117       centr(3) = unshu*(coonoe(s1,3)+coonoe(s2,3)
 118      >         + coonoe(s3,3)+coonoe(s4,3)+coonoe(s5,3)
 119      >         + coonoe(s6,3)+coonoe(s7,3)+coonoe(s8,3) )
 120 c     Le centre de la face 1
 121       of1(1) = unsqu*(coonoe(s1,1)+coonoe(s2,1)
 122      >       +        coonoe(s3,1)+coonoe(s4,1))
 123       of1(2) = unsqu*(coonoe(s1,2)+coonoe(s2,2)
 124      >       +        coonoe(s3,2)+coonoe(s4,2))
 125       of1(3) = unsqu*(coonoe(s1,3)+coonoe(s2,3)
 126      >       +        coonoe(s3,3)+coonoe(s4,3))
 127 c     Le centre de la face 2
 128       of2(1) = unsqu*(coonoe(s1,1)+coonoe(s2,1)
 129      >       +        coonoe(s5,1)+coonoe(s6,1))
 130       of2(2) = unsqu*(coonoe(s1,2)+coonoe(s2,2)
 131      >       +        coonoe(s5,2)+coonoe(s6,2))
 132       of2(3) = unsqu*(coonoe(s1,3)+coonoe(s2,3)
 133      >       +        coonoe(s5,3)+coonoe(s6,3))
 134 c     Le centre de la face 3
 135       of3(1) = unsqu*(coonoe(s1,1)+coonoe(s4,1)
 136      >       +        coonoe(s6,1)+coonoe(s7,1))
 137       of3(2) = unsqu*(coonoe(s1,2)+coonoe(s4,2)
 138      >       +        coonoe(s6,2)+coonoe(s7,2))
 139       of3(3) = unsqu*(coonoe(s1,3)+coonoe(s4,3)
 140      >       +        coonoe(s6,3)+coonoe(s7,3))
 141 c     Le centre de la face 4
 142       of4(1) = unsqu*(coonoe(s2,1)+coonoe(s3,1)
 143      >       +        coonoe(s5,1)+coonoe(s8,1))
 144       of4(2) = unsqu*(coonoe(s2,2)+coonoe(s3,2)
 145      >       +        coonoe(s5,2)+coonoe(s8,2))
 146       of4(3) = unsqu*(coonoe(s2,3)+coonoe(s3,3)
 147      >       +        coonoe(s5,3)+coonoe(s8,3))
 148 c     Le centre de la face 5
 149       of5(1) = unsqu*(coonoe(s3,1)+coonoe(s4,1)
 150      >       +        coonoe(s7,1)+coonoe(s8,1))
 151       of5(2) = unsqu*(coonoe(s3,2)+coonoe(s4,2)
 152      >       +        coonoe(s7,2)+coonoe(s8,2))
 153       of5(3) = unsqu*(coonoe(s3,3)+coonoe(s4,3)
 154      >       +        coonoe(s7,3)+coonoe(s8,3))
 155 c     Le centre de la face 6
 156       of6(1) = unsqu*(coonoe(s5,1)+coonoe(s6,1)
 157      >       +        coonoe(s7,1)+coonoe(s8,1))
 158       of6(2) = unsqu*(coonoe(s5,2)+coonoe(s6,2)
 159      >       +        coonoe(s7,2)+coonoe(s8,2))
 160       of6(3) = unsqu*(coonoe(s5,3)+coonoe(s6,3)
 161      >       +        coonoe(s7,3)+coonoe(s8,3))
 162 c
 163 c====
 164 c 3. volume et qualite des tetraedres
 165 c====
 166 c
 167 c     4 qual de tetra touchant la face 1
 168       call utqte2 ( qual( 1), volu( 1), coonoe, s1, s2, centr, of1 )
 169       call utqte2 ( qual( 2), volu( 2), coonoe, s2, s3, centr, of1 )
 170       call utqte2 ( qual( 3), volu( 3), coonoe, s3, s4, centr, of1 )
 171       call utqte2 ( qual( 4), volu( 4), coonoe, s1, s4, centr, of1 )
 172 c     4 qual( de tetra touchant la face 2
 173       call utqte2 ( qual( 5), volu( 5), coonoe, s1, s2, centr, of2 )
 174       call utqte2 ( qual( 6), volu( 6), coonoe, s2, s5, centr, of2 )
 175       call utqte2 ( qual( 7), volu( 7), coonoe, s5, s6, centr, of2 )
 176       call utqte2 ( qual( 8), volu( 8), coonoe, s1, s6, centr, of2 )
 177 c     4 qual( de tetra touchant la face 3
 178       call utqte2 ( qual( 9), volu( 9), coonoe, s1, s4, centr, of3 )
 179       call utqte2 ( qual(10), volu(10), coonoe, s4, s7, centr, of3 )
 180       call utqte2 ( qual(11), volu(11), coonoe, s6, s7, centr, of3 )
 181       call utqte2 ( qual(12), volu(12), coonoe, s1, s6, centr, of3 )
 182 c     4 qual( de tetra touchant la face 4
 183       call utqte2 ( qual(13), volu(13), coonoe, s2, s3, centr, of4 )
 184       call utqte2 ( qual(14), volu(14), coonoe, s3, s8, centr, of4 )
 185       call utqte2 ( qual(15), volu(15), coonoe, s5, s8, centr, of4 )
 186       call utqte2 ( qual(16), volu(16), coonoe, s2, s5, centr, of4 )
 187 c     4 qual( de tetra touchant la face 5
 188       call utqte2 ( qual(17), volu(17), coonoe, s3, s4, centr, of5 )
 189       call utqte2 ( qual(18), volu(18), coonoe, s4, s7, centr, of5 )
 190       call utqte2 ( qual(19), volu(19), coonoe, s7, s8, centr, of5 )
 191       call utqte2 ( qual(20), volu(20), coonoe, s3, s8, centr, of5 )
 192 c     4 qual( de tetra touchant la face 6
 193       call utqte2 ( qual(21), volu(21), coonoe, s5, s6, centr, of6 )
 194       call utqte2 ( qual(22), volu(22), coonoe, s6, s7, centr, of6 )
 195       call utqte2 ( qual(23), volu(23), coonoe, s7, s8, centr, of6 )
 196       call utqte2 ( qual(24), volu(24), coonoe, s5, s8, centr, of6 )
 197 c
 198       volume = volu(1)
 199       qualit = qual(1)
 200       do 10 , iaux = 2 , 24
 201         if (qual(iaux).gt.qualit) then
 202           qualit = qual(iaux)
 203         endif
 204         volume = volume + volu(iaux)
 205    10 continue
 206 c
 207 c====
 208 c 4. qualite par le jacobien normalise
 209 c====
 210 c 4.1. ==> Liens sommet/aretes
 211 c
 212       aresom(0,1) = 1
 213       aresom(1,1) = 1
 214       aresom(2,1) = 5
 215       aresom(3,1) = 2
 216 c
 217       aresom(0,2) = 2
 218       aresom(1,2) = 1
 219       aresom(2,2) = 3
 220       aresom(3,2) = 6
 221 c
 222       aresom(0,3) = 3
 223       aresom(1,3) = 4
 224       aresom(2,3) = 8
 225       aresom(3,3) = 3
 226 c
 227       aresom(0,4) = 4
 228       aresom(1,4) = 4
 229       aresom(2,4) = 2
 230       aresom(3,4) = 7
 231 c
 232       aresom(0,5) = 5
 233       aresom(1,5) = 6
 234       aresom(2,5) = 11
 235       aresom(3,5) = 9
 236 c
 237       aresom(0,6) = 6
 238       aresom(1,6) = 5
 239       aresom(2,6) = 9
 240       aresom(3,6) = 10
 241 c
 242       aresom(0,7) = 7
 243       aresom(1,7) = 10
 244       aresom(2,7) = 12
 245       aresom(3,7) = 7
 246 c
 247       aresom(0,8) = 8
 248       aresom(1,8) = 11
 249       aresom(2,8) = 8
 250       aresom(3,8) = 12
 251 c
 252 c 4.2. ==> fonction generique
 253 c
 254       iaux = 8
 255       daux = 1.d0
 256       call utqjno (   iaux, aresom,   daux,
 257      >              listar, listso, somare, coonoe,
 258      >              qualij )
 259 cgn      write(1,*) '==> qualij : ', qualij
 260 c
 261       end