src/tool/Decision/deinod.F

   1       subroutine deinod ( nivmin,
   2      >                    decare, decfac,
   3      >                    somare, hetare, filare,
   4      >                    np2are, posifa, facare,
   5      >                    aretri, hettri, nivtri,
   6      >                    arequa, hetqua, nivqua,
   7      >                    nosupp, noindi,
   8      >                    ulsort, langue, codret)
   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 traitement des DEcisions - Initialisation de l'indicateur entier
  30 c                --          -
  31 c                          - cas des NOeuds - Deraffinement
  32 c                                    --       -
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . nivmin . e   .   1    . niveau min a ne pas depasser en deraffinemt.
  38 c . decare .  s  .0:nbarto. decisions des aretes                       .
  39 c . decfac .  s  . -nbquto. decision sur les faces (quad. + tri.)      .
  40 c .        .     . :nbtrto.                                            .
  41 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  42 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  43 c . filare . e   . nbarto . premiere fille des aretes                  .
  44 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  45 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  46 c . nivtri . e   . nbtrto . niveau des triangles                       .
  47 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  48 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  49 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  50 c . nosupp . e   . nbnoto . support pour les noeuds                    .
  51 c . noindi . e   . nbnoto . valeurs entieres pour les noeuds           .
  52 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  53 c . langue . e   .    1   . langue des messages                        .
  54 c .        .     .        . 1 : francais, 2 : anglais                  .
  55 c . codret . es  .    1   . code de retour des modules                 .
  56 c .        .     .        . 0 : pas de probleme                        .
  57 c .        .     .        . 2 : probleme dans le traitement            .
  58 c ______________________________________________________________________
  59 c
  60 c====
  61 c 0. declarations et dimensionnement
  62 c====
  63 c
  64 c 0.1. ==> generalites
  65 c
  66       implicit none
  67       save
  68 c
  69       character*6 nompro
  70       parameter ( nompro = 'DEINOD' )
  71 c
  72 #include "nblang.h"
  73 c
  74 c 0.2. ==> communs
  75 c
  76 #include "envex1.h"
  77 #include "envca1.h"
  78 #include "nombno.h"
  79 #include "nombar.h"
  80 #include "nombtr.h"
  81 #include "nombqu.h"
  82 #include "impr02.h"
  83 c
  84 c 0.3. ==> arguments
  85 c
  86       integer nivmin
  87       integer decare(0:nbarto), decfac(-nbquto:nbtrto)
  88       integer somare(2,nbarto), hetare(nbarto), filare(nbarto)
  89       integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto)
  90       integer arequa(nbquto,4), hetqua(nbquto), nivqua(nbquto)
  91       integer np2are(nbarto), posifa(0:nbarto), facare(nbfaar)
  92       integer nosupp(nbnoto), noindi(nbnoto)
  93 c
  94       integer ulsort, langue, codret
  95 c
  96 c 0.4. ==> variables locales
  97 c
  98       integer somdec, etat
  99       integer larete, letria, lequad
 100       integer fille1, fille2
 101       integer iaux, jaux, kaux, ideb, ifin
 102 c
 103       integer nbmess
 104       parameter (nbmess = 10 )
 105       character*80 texte(nblang,nbmess)
 106 c ______________________________________________________________________
 107 c
 108 c====
 109 c 1. initialisation
 110 c====
 111 c
 112 #include "impr01.h"
 113 c
 114 #ifdef _DEBUG_HOMARD_
 115       write (ulsort,texte(langue,1)) 'Entree', nompro
 116       call dmflsh (iaux)
 117 #endif
 118 c
 119 #include "impr05.h"
 120 c
 121       codret = 0
 122 cgn      print *,decare
 123 cgn      print *,decfac
 124 cgn         do 1999 , iaux = 1, nbnoto
 125 cgn           if ( nosupp(iaux).ne.0 ) then
 126 cgn           write (ulsort,*) iaux,noindi(iaux)
 127 cgn           endif
 128 cgn 1999    continue
 129 c
 130 c====
 131 c 3. traitement des indicateurs portant sur les noeuds
 132 c====
 133 c
 134 #ifdef _DEBUG_HOMARD_
 135         write(ulsort,texte(langue,4)) mess14(langue,3,-1)
 136 #endif
 137 c
 138 #ifdef _DEBUG_HOMARD_
 139         write(ulsort,texte(langue,6))
 140 #endif
 141 c
 142         iaux = 0
 143 c
 144         if ( degre.eq.1 ) then
 145 c
 146           do 311 , larete = 1, nbarto
 147 cgn        write(ulsort,*) 'Arete', larete, ', etat',hetare(larete)
 148             etat = mod(hetare(larete),10)
 149             if ( etat.ge.2 ) then
 150               fille1 = filare(larete)
 151               fille2 = fille1 + 1
 152               if ( nosupp(somare(1,fille1)).ne.0 .and.
 153      >             nosupp(somare(2,fille1)).ne.0 .and.
 154      >             nosupp(somare(1,fille2)).ne.0 ) then
 155                 if ( noindi(somare(1,fille1)).eq.-1 .and.
 156      >               noindi(somare(2,fille1)).eq.-1 .and.
 157      >               noindi(somare(1,fille2)).eq.-1 ) then
 158                    ideb = posifa(larete-1)+1
 159                    ifin = posifa(larete)
 160                    jaux = 0
 161                    if ( ifin.ge.ideb ) then
 162                      if ( facare(ideb).gt.0 ) then
 163                        kaux = nivtri(facare(ideb))
 164                      else
 165                        kaux = nivqua(-facare(ideb))
 166                      endif
 167                      if ( kaux.lt.nivmin ) then
 168                        jaux = 1
 169                      endif
 170                    endif
 171                    if ( jaux.eq.0 ) then
 172 cgn        write(ulsort,*) 'Arete', larete, ' a reactiver'
 173 cgn     >, somare(1,fille1),somare(2,fille1),somare(1,fille2)
 174                      decare(larete) = -1
 175                    else
 176                      iaux = iaux + 1
 177                   endif
 178                 endif
 179               endif
 180             endif
 181   311     continue
 182 c
 183         else
 184 c
 185           do 312 , larete = 1, nbarto
 186             etat = mod(hetare(larete),10)
 187             if ( etat.ge.2 ) then
 188               fille1 = filare(larete)
 189               fille2 = fille1 + 1
 190               if ( nosupp(somare(1,fille1)).ne.0 .and.
 191      >             nosupp(somare(2,fille1)).ne.0 .and.
 192      >             nosupp(somare(1,fille2)).ne.0 .and.
 193      >             nosupp(np2are(fille1))  .ne.0 .and.
 194      >             nosupp(np2are(fille2))  .ne.0 ) then
 195                 if ( noindi(somare(1,fille1)).eq.-1 .and.
 196      >               noindi(somare(2,fille1)).eq.-1 .and.
 197      >               noindi(somare(1,fille2)).eq.-1 .and.
 198      >               noindi(np2are(fille1))  .eq.-1 .and.
 199      >               noindi(np2are(fille2))  .eq.-1 ) then
 200                   ideb = posifa(larete-1)+1
 201                   ifin = posifa(larete)
 202                   jaux = 0
 203                   if ( ifin.ge.ideb ) then
 204                     if ( facare(ideb).gt.0 ) then
 205                       kaux = nivtri(facare(ideb))
 206                     else
 207                       kaux = nivqua(-facare(ideb))
 208                     endif
 209                     if ( kaux.lt.nivmin ) then
 210                       jaux = 1
 211                     endif
 212                   endif
 213                   if ( jaux.eq.0 ) then
 214 cgn        write(ulsort,*) 'Arete', larete, ' a reactiver'
 215 cgn     >, somare(1,fille1),somare(2,fille1),somare(1,fille2)
 216                     decare(larete) = -1
 217                   else
 218                     iaux = iaux + 1
 219                   endif
 220                 endif
 221               endif
 222             endif
 223   312     continue
 224 c
 225         endif
 226 c
 227         if ( iaux.ne.0 ) then
 228           write(ulsort,texte(langue,10))
 229           write(ulsort,texte(langue,4)) mess14(langue,3,-1)
 230           write(ulsort,texte(langue,8)) nivmin
 231           write(ulsort,texte(langue,9)) iaux
 232         endif
 233 c
 234         do 313 , letria = 1, nbtrto
 235           etat = mod(hettri(letria),10)
 236           if ( etat.eq.4 .or.
 237      >         etat.eq.6 .or. etat.eq.7 .or. etat.eq.8 .or.
 238      >         etat.eq.9  ) then
 239             somdec = decare(aretri(letria,1))
 240      >             + decare(aretri(letria,2))
 241      >             + decare(aretri(letria,3))
 242             if (somdec.eq.-3) then
 243 cgn        write(ulsort,*) 'Triangle', letria, ' a reactiver'
 244               decfac(letria) = -1
 245             endif
 246           endif
 247   313   continue
 248 c
 249         do 314 , lequad = 1, nbquto
 250           etat = mod(hetqua(lequad),100)
 251           if ( etat.eq.4 .or.
 252      >         etat.eq.99  ) then
 253             somdec = decare(arequa(lequad,1))
 254      >             + decare(arequa(lequad,2))
 255      >             + decare(arequa(lequad,3))
 256      >             + decare(arequa(lequad,4))
 257             if (somdec.eq.-4) then
 258 cgn        write(ulsort,*) 'Quadrangle', lequad, ' a reactiver'
 259               decfac(-lequad) = -1
 260             endif
 261           endif
 262   314   continue
 263 c
 264 c====
 265 c 4. la fin
 266 c====
 267 c
 268       if ( codret.ne.0 ) then
 269 c
 270 #include "envex2.h"
 271 c
 272       write (ulsort,texte(langue,1)) 'Sortie', nompro
 273       write (ulsort,texte(langue,2)) codret
 274 c
 275       endif
 276 c
 277 #ifdef _DEBUG_HOMARD_
 278       write (ulsort,texte(langue,1)) 'Sortie', nompro
 279       call dmflsh (iaux)
 280 #endif
 281 c
 282       end