src/tool/Utilitaire/utqpyr.F

   1       subroutine utqpyr ( lapyra, qualit, qualij, volume,
   2      >                    coonoe, somare, aretri,
   3      >                    facpyr, cofapy, arepyr )
   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'une PYRamide
  25 c     --           -             ---
  26 c ______________________________________________________________________
  27 c
  28 c     . Jacobien normalise
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . lapyra . e   .  1     . numero de la pyramide a examiner           .
  34 c . qualit .  s  .  1     . qualite non definie                        .
  35 c . qualij .  s  .  1     . qualite par le jacobien normalise          .
  36 c . volume .  s  .  1     . volume                                     .
  37 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  38 c .        .     . * sdim .                                            .
  39 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  40 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  41 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  42 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  43 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  44 c ______________________________________________________________________
  45 c
  46 c====
  47 c 0. declarations et dimensionnement
  48 c====
  49 c
  50 c 0.1. ==> generalites
  51 c
  52       implicit none
  53       save
  54 c
  55 c 0.2. ==> communs
  56 c
  57 #include "nombno.h"
  58 #include "nombar.h"
  59 #include "nombtr.h"
  60 #include "nombpy.h"
  61 c
  62 c 0.3. ==> arguments
  63 c
  64       double precision qualit, qualij, volume
  65       double precision coonoe(nbnoto,3)
  66 c
  67       integer lapyra
  68       integer somare(2,nbarto)
  69       integer aretri(nbtrto,3)
  70       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
  71 c
  72 c 0.4. ==> variables locales
  73 c
  74       integer iaux
  75       integer aresom(0:3,8)
  76       integer listar(8), listso(5)
  77 c
  78       double precision daux
  79 c
  80 c 0.5. ==> initialisations
  81 c ______________________________________________________________________
  82 c
  83 c                            S5
  84 c                            x
  85 c                         . . . .
  86 c                       .  .   .   .
  87 c                     .   .   a4.     .
  88 c                   .    .       .       .
  89 c                 .     .        x .         .
  90 c            a1 .      .     .   S4    .        .a3
  91 c             .       .  .                 .       .
  92 c           .        .                         .      .
  93 c         .      .  .                           a7 .     .
  94 c       .    .a8   .                                   .    .
  95 c     .  .        .                                        .   .
  96 c S1 .           .a2                                           .  .
  97 c  x .         .                                                  .  .
  98 c     a5  .    .                                                      .
  99 c             x--------------------------------------------------------x
 100 c           S2                            a6                          S3
 101 c   La face f5 est le quadrangle.
 102 c   La face fi, i<5, est le triangle s'appuyant sur l'arete ai.
 103 c
 104 c====
 105 c 1. les aretes et les sommets
 106 c====
 107 c
 108       call utaspy ( lapyra,
 109      >              nbtrto, nbpycf, nbpyca,
 110      >              somare, aretri,
 111      >              facpyr, cofapy, arepyr,
 112      >              listar, listso )
 113 c
 114 c====
 115 c 2. volume
 116 c====
 117 c
 118       call utvopy ( coonoe, listso, volume )
 119 c
 120 c====
 121 c 3. qualite bidon
 122 c====
 123 c
 124       qualit = -1789.d0
 125 c
 126 c====
 127 c 4. qualite par le jacobien normalise
 128 c====
 129 c 4.1. ==> Liens sommet/aretes
 130 c
 131       aresom(0,1) = 1
 132       aresom(1,1) = 5
 133       aresom(2,1) = 8
 134       aresom(3,1) = 1
 135 c
 136       aresom(0,2) = 2
 137       aresom(1,2) = 6
 138       aresom(2,2) = 5
 139       aresom(3,2) = 2
 140 c
 141       aresom(0,3) = 3
 142       aresom(1,3) = 7
 143       aresom(2,3) = 6
 144       aresom(3,3) = 3
 145 c
 146       aresom(0,4) = 4
 147       aresom(1,4) = 8
 148       aresom(2,4) = 7
 149       aresom(3,4) = 4
 150 c
 151       aresom(0,5) = 5
 152       aresom(1,5) = 2
 153       aresom(2,5) = 1
 154       aresom(3,5) = 4
 155 c
 156       aresom(0,6) = 5
 157       aresom(1,6) = 3
 158       aresom(2,6) = 2
 159       aresom(3,6) = 1
 160 c
 161       aresom(0,7) = 5
 162       aresom(1,7) = 4
 163       aresom(2,7) = 3
 164       aresom(3,7) = 2
 165 c
 166       aresom(0,8) = 5
 167       aresom(1,8) = 1
 168       aresom(2,8) = 4
 169       aresom(3,8) = 3
 170 c
 171 c 4.2. ==> fonction generique
 172 c
 173       iaux = 8
 174       daux = sqrt(2.d0)/2.d0
 175       call utqjno (   iaux, aresom,   daux,
 176      >              listar, listso, somare, coonoe,
 177      >              qualij )
 178 cgn      write(1,*) '==> qualij : ', qualij
 179 c
 180       end