src/tool/Creation_Maillage/cmdrar.F

   1       subroutine cmdrar ( hetare, filare, np2are, somare,
   2      >                    decare,
   3      >                    disare, disnoe, distri, disqua,
   4      >                    hetnoe, posifa, facare, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c    Creation du Maillage - Deraffinement - Regroupement des ARetes
  26 c    -           -          -               -                --
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . hetare . e   . nouvar . historique de l'etat des aretes            .
  32 c . filare . e   . nouvar . premiere fille des aretes                  .
  33 c . np2are . e   . nouvar . numero des noeuds p2 milieux d'aretes      .
  34 c . somare . e   .2*nouvar. numeros des extremites d'arete             .
  35 c . decare . e   .0:nbarto. table des decisions sur les aretes         .
  36 c . disare . e   . nouvar . indicateurs de disparition des aretes      .
  37 c . disnoe . e   . nouvno . indicateurs de disparition des noeuds      .
  38 c . distri . e   . nouvtr . indicateurs de disparition des triangles   .
  39 c . disqua . e   . nouvqu . indicateurs de disparition des quadrangles .
  40 c . hetnoe . e/s . nouvno . historique de l'etat des noeuds            .
  41 c . posifa . e   .0:nbarto. pointeur sur tableau facare                .
  42 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  43 c . codret .   s .   1    . code de retour, 0 si ok, (no arete) si pb  .
  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 cgn      character*6 nompro
  56 cgn      parameter ( nompro = 'CMRDAR' )
  57 c
  58 c 0.2. ==> communs
  59 c
  60 #include "envca1.h"
  61 #include "nombar.h"
  62 #include "nouvnb.h"
  63 c
  64 c 0.3. ==> arguments
  65 c
  66 c     remarque : "disnoe", "disare", "distet" et "distri" sont des
  67 c     tableaux temporaires destines a la suppression ulterieure des
  68 c     entites. par convention, une valeur 0 indique la conservation et
  69 c     une valeur 1 la disparition de l'entite concernee par la liste.
  70 c
  71       integer hetare(nouvar),   filare(nouvar),   np2are(nouvar)
  72       integer somare(2,nouvar), decare(0:nbarto), disare(nouvar)
  73       integer disnoe(nouvno),   hetnoe(nouvno),   codret
  74       integer distri(nouvtr), disqua(nouvqu)
  75       integer posifa(0:nbarto), facare(nbfaar)
  76 c
  77 c 0.4. ==> variables locales
  78 c
  79       integer larete, lafill, noemil, noefil
  80       integer ideb,   ifin,   facvoi, nbdisp
  81       integer iaux
  82 c
  83 c 0.5. ==> initialisations
  84 c
  85       codret = 0
  86 c ______________________________________________________________________
  87 c
  88 c====
  89 c 1. traitement des aretes
  90 c====
  91 c
  92       do 100 , larete = 1 , nbarpe
  93 c
  94 c 1.1   dans le cas ou l'arete est mere d'active
  95 c
  96         if ( mod( hetare(larete) , 10 ) .eq. 2 ) then
  97 c
  98 c 1.1.1   dans le cas ou l'arete est marquee "a reactiver"
  99 c
 100           if ( decare(larete) .eq. -1 ) then
 101 c
 102 c             on verifie que les faces voisines des aretes filles de
 103 c             l'arete consideree sont toutes marquees a disparaitre.
 104 c             pour cela, on comptabilise (en negatif) le nombre de faces
 105 c             voisines des aretes fille marquees a disparaitre. si le
 106 c             total est nul, c'est que toutes les faces doivent bien
 107 c             disparaitre. dans ce cas, et dans ce cas seulement,
 108 c             on pourra marquer les aretes filles comme etant a
 109 c             disparaitre.
 110 c
 111 c             test des faces voisines de la premiere arete fille
 112 c
 113             lafill = filare(larete)
 114             ideb = posifa(lafill - 1) + 1
 115             ifin = posifa(lafill)
 116 c
 117             nbdisp = ifin - ideb + 1
 118             do 210 , facvoi = ideb , ifin
 119               if ( facare(facvoi).gt.0 ) then
 120                 if (distri(facare(facvoi)).eq.1) then
 121                   nbdisp = nbdisp - 1
 122                 endif
 123               else
 124                 if (disqua(-facare(facvoi)).eq.1) then
 125                   nbdisp = nbdisp - 1
 126                 endif
 127               endif
 128  210        continue
 129 c
 130 c             test des faces voisines de la seconde arete fille
 131 c
 132             lafill = filare(larete) + 1
 133             ideb = posifa(lafill - 1) + 1
 134             ifin = posifa(lafill)
 135 c
 136             nbdisp = ifin - ideb + 1 + nbdisp
 137             do 212 , facvoi = ideb , ifin
 138               if ( facare(facvoi).gt.0 ) then
 139                 if (distri(facare(facvoi)).eq.1) then
 140                   nbdisp = nbdisp - 1
 141                 endif
 142               else
 143                 if (disqua(-facare(facvoi)).eq.1) then
 144                   nbdisp = nbdisp - 1
 145                 endif
 146               endif
 147  212        continue
 148 c
 149 c             verification du nombre de faces marquees a disparaitre
 150 c             (il ne doit pas en rester, qui ne soit pas marquees a
 151 c             disparaitre, pour pouvoir eliminer les aretes filles)
 152 c
 153             if ( nbdisp .eq. 0 ) then
 154 c
 155 c 1.1.1.1   marquage de ses deux aretes filles "a disparaitre"
 156 c
 157               lafill = filare(larete)
 158               disare( lafill )     = 1
 159               disare( lafill + 1 ) = 1
 160 c
 161 c 1.1.1.2   marquage des noeuds milieux "a disparaitre"
 162 c
 163               noemil = 0
 164               noefil = somare(1,lafill)
 165               if ( ( noefil .eq. somare(1,lafill+1) ).or.
 166      >             ( noefil .eq. somare(2,lafill+1) ) ) then
 167                 noemil = noefil
 168               endif
 169               noefil = somare(2,lafill)
 170               if ( ( noefil .eq. somare(1,lafill+1) ).or.
 171      >             ( noefil .eq. somare(2,lafill+1) ) ) then
 172                 noemil = noefil
 173               endif
 174 c
 175               if ( noemil .eq. 0 ) then
 176                 codret = larete
 177               endif
 178 c
 179               if ( degre .eq. 2 ) then
 180 c
 181                 disnoe(np2are(lafill))     = 1
 182                 disnoe(np2are(lafill + 1)) = 1
 183 c
 184 c             modification de l'etat du noeud p1 milieu en p2 :
 185 c             . son etat anterieur, la dizaine, est conserve
 186 c             . son etat courant passe de 1, P1, a 2, P2
 187 c
 188                 iaux = hetnoe(noemil) - mod(hetnoe(noemil),10)
 189                 hetnoe(noemil) = iaux + 2
 190 c
 191                 if ( noemil .ne. np2are(larete) ) then
 192                   codret = larete
 193                 endif
 194 c
 195               else
 196 c
 197                 disnoe(noemil) = 1
 198 c
 199               endif
 200 c
 201             endif
 202 c
 203           endif
 204 c
 205         endif
 206 c
 207   100 continue
 208 c
 209       end