src/tool/Creation_Maillage/cmdrhe.F

   1       subroutine cmdrhe ( arequa, decfac, quahex, hethex,
   2      >                    filhex, disare, disqua, dishex,
   3      >                    somare, disnoe,
   4      >                    np2are,
   5      >                    codret )
   6 c
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c    Creation du Maillage - Deraffinement - Regroupement des Hexaedres
  28 c    -           -          -               -                --
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . arequa . e   .nouvqu*4. numeros des 4 aretes des quadrangles       .
  34 c . decfac . e   . -nbquto. decision sur les faces (quad. + tri.)      .
  35 c .        .     . :nbtrto.                                            .
  36 c . quahex . e   .nouvhf*6. numeros des 6 quadrangles des hexaedres    .
  37 c . hethex . e   . nouvhe . historique de l'etat des hexaedres         .
  38 c . filhex . e   . nouvhe . premier fils des hexaedres                 .
  39 c . disare .   s . nouvar . indicateurs de disparition des aretes      .
  40 c . disqua .   s . nouvqu . indicateurs de disparition des quadrangles .
  41 c . dishex .   s . nouvhe . indicateurs de disparition des hexaedres   .
  42 c . somare . e   .2*nouvar. numeros des extremites d'arete             .
  43 c . disnoe .   s . nouvno . indicateurs de disparition des noeuds      .
  44 c . np2are . e   . nouvar . numero des noeuds p2 milieux d'aretes      .
  45 c . codret . e/s .   1    . code de retour des modules                 .
  46 c .        .     .        . 0 : pas de probleme                        .
  47 c ______________________________________________________________________
  48 c
  49 c====
  50 c 0. declarations et dimensionnement
  51 c====
  52 c
  53 c 0.1. ==> generalites
  54 c
  55       implicit none
  56       save
  57 c
  58 #ifdef _DEBUG_HOMARD_
  59       character*6 nompro
  60       parameter ( nompro = 'CMDRHE' )
  61 #endif
  62 c
  63 c 0.2. ==> communs
  64 c
  65 #include "envca1.h"
  66 #include "nombtr.h"
  67 #include "nombqu.h"
  68 #include "nombhe.h"
  69 #include "nouvnb.h"
  70 c
  71 c 0.3. ==> arguments
  72 c
  73 c     remarque : "disnoe", "disare", "dishex" et "disqua" sont des
  74 c     tableaux temporaires destines a la suppression ulterieure des
  75 c     entites. par convention, une valeur 0 indique la conservation et
  76 c     une valeur 1 la disparition de l'entite concernee par la liste.
  77 c
  78       integer decfac(-nbquto:nbtrto)
  79       integer arequa(nouvqu,4)
  80       integer quahex(nouvhf,6)
  81       integer hethex(nouvhe),   filhex(nouvhe),   disare(nouvar)
  82       integer disqua(nouvqu),   dishex(nouvhe),   disnoe(nouvno)
  83       integer somare(2,nouvar)
  84       integer np2are(nouvar)
  85 c
  86       integer codret
  87 c
  88 c 0.4. ==> variables locales
  89 c
  90       integer pf1n5, pf1n6, pf1n7, pf1n8
  91       integer pf2n2, pf2n3, pf2n10, pf2n11
  92       integer pf3n1, pf3n4, pf3n9, pf3n12
  93       integer nf1n0,nf2n0,nf3n0,nf4n0,nf5n0,nf6n0
  94 c
  95       integer lehexa, lefils, leprem
  96       integer etahex, dt, d1, d2, d3, d4, d5, d6
  97 c
  98 c 0.5. ==> initialisations
  99 c
 100 #include "impr03.h"
 101 c
 102       codret = 0
 103 c ______________________________________________________________________
 104 c
 105 c====
 106 c 1. traitement des hexaedres
 107 c====
 108 c
 109       do 100 , lehexa = 1 , nbhepe
 110 c
 111         etahex = mod(hethex(lehexa),1000)
 112 c
 113         if ( etahex.eq.8 ) then
 114 c
 115 c 1.1. ==> verification de l'etat des 6 faces de l'hexaedre
 116 c         attention, cette methode pour verifier l'etat n'est valable
 117 c         que si la seule solution pour obtenir "-6" a partir des
 118 c         decisions sur les faces est d'avoir 6 fois "-1",
 119 c         et idem pour "-5", "-4" ou "-3".
 120 c
 121           d1 = decfac(-quahex(lehexa,1))
 122           d2 = decfac(-quahex(lehexa,2))
 123           d3 = decfac(-quahex(lehexa,3))
 124           d4 = decfac(-quahex(lehexa,4))
 125           d5 = decfac(-quahex(lehexa,5))
 126           d6 = decfac(-quahex(lehexa,6))
 127           dt = d1 + d2 + d3 + d4 + d5 + d6
 128 c
 129 c 1.2. ==> cas ou les 6 faces du hexaedre sont a reactiver
 130 c
 131           if ( dt.le.-3 ) then
 132 c
 133 c 1.2.1. ==> marquage de ses huit hexaedres fils "a disparaitre"
 134 c
 135             leprem = filhex(lehexa)
 136 c
 137             do 210 , lefils = leprem , leprem + 7
 138 c
 139               dishex(lefils) = 1
 140 c
 141  210        continue
 142 c
 143 c 1.2.2. ==> marquage de ses douze faces internes "a disparaitre"
 144 c
 145             lefils = leprem
 146             pf1n5=quahex(lefils,6)
 147             disqua(pf1n5)=1
 148             pf2n2=quahex(lefils,5)
 149             disqua(pf2n2)=1
 150             pf3n1=quahex(lefils,4)
 151             disqua(pf3n1)=1
 152 c
 153             lefils=lefils+1
 154             pf2n3=quahex(lefils,5)
 155             disqua(pf2n3)=1
 156             pf1n6=quahex(lefils,6)
 157             disqua(pf1n6)=1
 158 c
 159             lefils=lefils+1
 160             pf3n4=quahex(lefils,3)
 161             disqua(pf3n4)=1
 162             pf1n8=quahex(lefils,6)
 163             disqua(pf1n8)=1
 164 c
 165             lefils=lefils+1
 166             pf1n7=quahex(lefils,6)
 167             disqua(pf1n7)=1
 168 c
 169             lefils=lefils+1
 170             pf3n9=quahex(lefils,3)
 171             disqua(pf3n9)=1
 172             pf2n11=quahex(lefils,5)
 173             disqua(pf2n11)=1
 174 c
 175             lefils=lefils+1
 176             pf2n10=quahex(lefils,5)
 177             disqua(pf2n10)=1
 178 c
 179             lefils=lefils+1
 180             pf3n12=quahex(lefils,4)
 181             disqua(pf3n12)=1
 182 c
 183 c 1.2.3. ==> recherche des aretes internes "a disparaitre"
 184 c
 185             nf1n0=arequa(pf2n2,2)
 186             disare(nf1n0)=1
 187             if ( degre.eq.2 ) then
 188               disnoe(np2are(nf1n0)) = 1
 189             endif
 190 c
 191             nf2n0=arequa(pf1n6,2)
 192             disare(nf2n0)=1
 193             if ( degre.eq.2 ) then
 194               disnoe(np2are(nf2n0)) = 1
 195             endif
 196 c
 197             nf3n0=arequa(pf1n5,2)
 198             disare(nf3n0)=1
 199             if ( degre.eq.2 ) then
 200               disnoe(np2are(nf3n0)) = 1
 201             endif
 202 c
 203             nf4n0=arequa(pf1n8,2)
 204             disare(nf4n0)=1
 205             if ( degre.eq.2 ) then
 206               disnoe(np2are(nf4n0)) = 1
 207             endif
 208 c
 209             nf5n0=arequa(pf1n7,2)
 210             disare(nf5n0)=1
 211             if ( degre.eq.2 ) then
 212               disnoe(np2are(nf5n0)) = 1
 213             endif
 214 c
 215             nf6n0=arequa(pf3n9,2)
 216             disare(nf6n0)=1
 217             if ( degre.eq.2 ) then
 218               disnoe(np2are(nf6n0)) = 1
 219             endif
 220 c
 221 c 1.2.4. ==> recherche du point central
 222 c
 223             disnoe(somare(2,nf1n0)) = 1
 224 c
 225           endif
 226 c
 227         endif
 228 c
 229   100 continue
 230 c
 231       end