src/tool/Creation_Maillage/cmdrpe.F

   1       subroutine cmdrpe ( aretri, decfac,
   2      >                    facpen, hetpen,
   3      >                    filpen,
   4      >                    disare, distri, disqua, dispen,
   5      >                    disnoe,
   6      >                    np2are,
   7      >                    codret )
   8 c
   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    Creation du Maillage - Deraffinement - Regroupement des Pentaedres
  30 c    -           -          -               -                --
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . aretri . e   .nouvtr*3. numeros des 3 aretes des triangles         .
  36 c . decfac . e   . -nbquto. decision sur les faces (quad. + tri.)      .
  37 c .        .     . :nbtrto.                                            .
  38 c . facpen . e   .nouvpf*5. numeros des faces des pentaedres           .
  39 c . hetpen . e   . nouvpe . historique de l'etat des pentaedres        .
  40 c . filpen . e   . nouvpe . premier fils des pentaedres                .
  41 c . disare .   s . nouvar . indicateurs de disparition des aretes      .
  42 c . distri .   s . nouvtr . indicateurs de disparition des triangles   .
  43 c . disqua .   s . nouvqu . indicateurs de disparition des quadrangles .
  44 c . dispen .   s . nouvpe . indicateurs de disparition des pentaedres  .
  45 c . disnoe .   s . nouvno . indicateurs de disparition des aretes      .
  46 c . np2are . e   . nouvar . numero des noeuds p2 milieux d'aretes      .
  47 c . codret . e/s .   1    . code de retour des modules                 .
  48 c .        .     .        . 0 : pas de probleme                        .
  49 c ______________________________________________________________________
  50 c
  51 c====
  52 c 0. declarations et dimensionnement
  53 c====
  54 c
  55 c 0.1. ==> generalites
  56 c
  57       implicit none
  58       save
  59 c
  60 cgn      character*6 nompro
  61 cgn      parameter ( nompro = 'CMDRPE' )
  62 c
  63 c 0.2. ==> communs
  64 c
  65 #include "envca1.h"
  66 #include "nombtr.h"
  67 #include "nombqu.h"
  68 #include "nombpe.h"
  69 #include "nouvnb.h"
  70 c
  71 c 0.3. ==> arguments
  72 c
  73 c     remarque : "disnoe", "disare", "dispen" 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 aretri(nouvtr,3)
  80       integer facpen(nouvpe,5)
  81       integer hetpen(nouvpe),   filpen(nouvpe),   disare(nouvar)
  82       integer distri(nouvtr), disqua(nouvqu)
  83       integer dispen(nouvpe), disnoe(nouvno)
  84       integer np2are(nouvar)
  85 c
  86       integer codret
  87 c
  88 c 0.4. ==> variables locales
  89 c
  90       integer nf3nf4, nf4nf5, nf5nf3
  91       integer pf3f1, pf3f2, pf4f1, pf4f2, pf5f1, pf5f2
  92       integer pf1, pf1n7, pf1n8, pf1n9
  93 c
  94       integer lepent, lefils, leprem
  95       integer etapen, dt, d1, d2, d3, d4, d5
  96 c
  97 c 0.5. ==> initialisations
  98 c
  99       codret = 0
 100 c ______________________________________________________________________
 101 c
 102 c====
 103 c 1. traitement des pentaedres
 104 c====
 105 c
 106       do 100 , lepent = 1 , nbpepe
 107 c
 108         etapen = mod(hetpen(lepent),100)
 109 c
 110         if ( etapen.eq.80 ) then
 111 c
 112 c         Le pentaedre est coupe en 8.
 113 c         Il est a reactiver dans 2 cas :
 114 c           . ses 5 faces sont a reactiver : decision -1 pour chacune
 115 c           . 4 faces sont a reactiver : decision -1 pour chacune
 116 c             la derniere reste coupee : decision 0
 117 c         donc des que la somme des decisions est <= -4
 118 c
 119           d1 = decfac(facpen(lepent,1))
 120           d2 = decfac(facpen(lepent,2))
 121           d3 = decfac(-facpen(lepent,3))
 122           d4 = decfac(-facpen(lepent,4))
 123           d5 = decfac(-facpen(lepent,5))
 124           dt = d1 + d2 + d3 + d4 + d5
 125 cgn          print *,'pour penta ',lepent,', dt = ',dt
 126 c
 127           if ( dt.le.-4 ) then
 128 c
 129 c 1.2.1. ==> marquage de ses huit pentaedres fils "a disparaitre"
 130 c
 131             leprem = filpen(lepent)
 132 c
 133             do 210 , lefils = leprem , leprem + 7
 134 c
 135               dispen(lefils) = 1
 136 c
 137  210        continue
 138 c
 139 c 1.2.2. ==> marquage de ses six quadrangles internes "a disparaitre"
 140 c
 141             lefils = leprem + 6
 142             pf3f1 = facpen(lefils,3)
 143             disqua(pf3f1) = 1
 144             pf4f1 = facpen(lefils,4)
 145             disqua(pf4f1) = 1
 146             pf5f1 = facpen(lefils,5)
 147             disqua(pf5f1) = 1
 148 c
 149             lefils = lefils + 1
 150             pf3f2 = facpen(lefils,3)
 151             disqua(pf3f2) = 1
 152             pf4f2 = facpen(lefils,4)
 153             disqua(pf4f2) = 1
 154             pf5f2 = facpen(lefils,5)
 155             disqua(pf5f2) = 1
 156 c
 157 c 1.2.3. ==> marquage de ses quatre triangles internes "a disparaitre"
 158 c
 159             lefils = leprem
 160             pf1n7 = facpen(lefils,2)
 161             distri(pf1n7) = 1
 162 c
 163             lefils = leprem + 1
 164             pf1n8 = facpen(lefils,2)
 165             distri(pf1n8) = 1
 166 c
 167             lefils = leprem + 2
 168             pf1n9 = facpen(lefils,2)
 169             distri(pf1n9) = 1
 170 c
 171             lefils = leprem + 6
 172             pf1 = facpen(lefils,2)
 173             distri(pf1) = 1
 174 c
 175 c 1.2.4. ==> marquage des trois des aretes internes "a disparaitre"
 176 c
 177             nf3nf4 = aretri(pf1,1)
 178             disare(nf3nf4) = 1
 179             if ( degre.eq.2 ) then
 180               disnoe(np2are(nf3nf4)) = 1
 181             endif
 182 c
 183             nf4nf5 = aretri(pf1,2)
 184             disare(nf4nf5) = 1
 185             if ( degre.eq.2 ) then
 186               disnoe(np2are(nf4nf5)) = 1
 187             endif
 188 c
 189             nf5nf3 = aretri(pf1,3)
 190             disare(nf5nf3) = 1
 191             if ( degre.eq.2 ) then
 192               disnoe(np2are(nf5nf3)) = 1
 193             endif
 194 c
 195           endif
 196 c
 197         endif
 198 c
 199   100 continue
 200 c
 201       end