src/tool/Decision/derco3.F

   1       subroutine derco3 ( niveau,
   2      >                    decare, decfac,
   3      >                    merare,
   4      >                    posifa, facare,
   5      >                    hettri, aretri, pertri, nivtri,
   6      >                    voltri,
   7      >                    hetqua, arequa, perqua, nivqua,
   8      >                    tritet,
   9      >                    ulsort, langue, codret )
  10 c ______________________________________________________________________
  11 c
  12 c                             H O M A R D
  13 c
  14 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  15 c
  16 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  17 c aupres des huissiers de justice Simart et Lavoir a Clamart
  18 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  19 c aupres des huissiers de justice
  20 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  21 c
  22 c    HOMARD est une marque deposee d'Electricite de France
  23 c
  24 c Copyright EDF 1996
  25 c Copyright EDF 1998
  26 c Copyright EDF 2002
  27 c Copyright EDF 2020
  28 c ______________________________________________________________________
  29 c
  30 c traitement des DEcisions - Raffinement : COntamination - option 3
  31 c                --          -             --                     -
  32 c Complement sur la regle des ecarts de niveau pour du non-conforme
  33 c a 1 noeud pendant par arete
  34 c Remarque : cela ne peut concerner que des niveaux au moins egal a 2
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . niveau . e   .    1   . niveau en cours d'examen                   .
  40 c . decare . es  . nbarto . decisions des aretes                       .
  41 c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
  42 c .        .     . :nbtrto.                                            .
  43 c . merare . e   . nbarto . mere des aretes                            .
  44 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  45 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  46 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  47 c . aretri . e   . nbtrto . numeros des 3 aretes des triangles         .
  48 c . pertri . e   . nbtrto . pere des triangles                         .
  49 c . nivtri . e   . nbtrto . niveau des triangles                       .
  50 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  51 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  52 c .        .     .        .   0 : pas de voisin                        .
  53 c .        .     .        . j>0 : tetraedre j                          .
  54 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  55 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  56 c . arequa . e   . nbquto . numeros des 4 aretes des quadrangles       .
  57 c . perqua . e   . nbquto . pere des quadrangles                       .
  58 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  59 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  60 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  61 c . langue . e   .    1   . langue des messages                        .
  62 c .        .     .        . 1 : francais, 2 : anglais                  .
  63 c . codret . es  .    1   . code de retour des modules                 .
  64 c .        .     .        . 0 : pas de probleme                        .
  65 c ______________________________________________________________________
  66 c
  67 c====
  68 c 0. declarations et dimensionnement
  69 c====
  70 c
  71 c 0.1. ==> generalites
  72 c
  73       implicit none
  74       save
  75 c
  76       character*6 nompro
  77       parameter ( nompro = 'DERCO3' )
  78 c
  79 #include "nblang.h"
  80 c
  81 c 0.2. ==> communs
  82 c
  83 #include "envex1.h"
  84 #include "nombar.h"
  85 #include "nombtr.h"
  86 #include "nombqu.h"
  87 #include "nombte.h"
  88 c
  89 c 0.3. ==> arguments
  90 c
  91       integer niveau
  92       integer decare(0:nbarto)
  93       integer decfac(-nbquto:nbtrto)
  94       integer merare(nbarto)
  95       integer posifa(0:nbarto), facare(nbfaar)
  96       integer hettri(nbtrto), aretri(nbtrto,3)
  97       integer pertri(nbtrto), nivtri(nbtrto)
  98       integer voltri(2,nbtrto)
  99       integer hetqua(nbquto), arequa(nbquto,4)
 100       integer perqua(nbquto), nivqua(nbquto)
 101       integer tritet(nbtecf,4)
 102 c
 103       integer ulsort, langue, codret
 104 c
 105 c 0.4. ==> variables locales
 106 c
 107       integer laface, tetrae, nbtetr
 108       integer ipos
 109       integer iaux, ideb, ifin
 110       integer iarelo, jarelo, ifalo, iarete, jarete, iface, itetra
 111       integer etatfa, merear, merefa, grdmfa
 112       integer nbare1, nbare2, liare1(4), liare2(4)
 113 c
 114       integer nbmess
 115       parameter ( nbmess = 30 )
 116       character*80 texte(nblang,nbmess)
 117 c
 118 c 0.5. ==> initialisations
 119 c ______________________________________________________________________
 120 c
 121 c====
 122 c 1. initialisations
 123 c====
 124 c
 125 #include "impr01.h"
 126 c
 127 #ifdef _DEBUG_HOMARD_
 128       write (ulsort,texte(langue,1)) 'Entree', nompro
 129       call dmflsh (iaux)
 130 #endif
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133 #include "impr03.h"
 134 #endif
 135 c
 136 #include "derco1.h"
 137 c
 138 #ifdef _DEBUG_HOMARD_
 139       write (ulsort,texte(langue,12)) niveau
 140 #endif
 141 c
 142       codret = 0
 143 c
 144 c  nombre maximum de tetraedres par triangle
 145 c
 146       if ( nbteto.eq.0 ) then
 147         nbtetr = 0
 148       else
 149         nbtetr = 2
 150       endif
 151 c
 152 c====
 153 c 2. Complements sur la regle des ecarts de niveau
 154 c====
 155 c
 156       do 2 , laface = -nbquto , nbtrto
 157 cgn        print *,'entree de ',nompro,', ',laface,' :',decfac(laface)
 158 c
 159 c 2.1. ==> on s'interesse aux faces :
 160 c          . du niveau courant
 161 c          . actives
 162 c          . qui ont une mere qui ne reapparait pas
 163 c          . qui ont une grand-mere
 164 c
 165         grdmfa = 0
 166 c
 167         if ( laface.gt.0 ) then
 168 c
 169           if ( nivtri(laface).eq.niveau ) then
 170             etatfa = mod( hettri(laface) , 10 )
 171             if ( etatfa.eq.0 ) then
 172               merefa = pertri(laface)
 173               if ( merefa.gt.0 ) then
 174                 if ( decfac(merefa).eq.0 ) then
 175                   grdmfa = pertri(merefa)
 176                 endif
 177               endif
 178             endif
 179           endif
 180 c
 181         elseif ( laface.lt.0 ) then
 182 c
 183           iaux = -laface
 184           if ( nivqua(iaux).eq.niveau ) then
 185             etatfa = mod( hetqua(iaux) , 100 )
 186             if ( etatfa.eq.0 ) then
 187               merefa = perqua(iaux)
 188               if ( merefa.gt.0 ) then
 189                 if ( decfac(-merefa).eq.0 ) then
 190                   grdmfa = perqua(merefa)
 191                 endif
 192               endif
 193             endif
 194           endif
 195 c
 196         endif
 197 c
 198 c 2.2. ==> on regarde les aretes de la face mere
 199 c
 200         if ( grdmfa.gt.0 ) then
 201 c
 202 c 2.2.1. ==> liste de ces aretes
 203 c
 204           if ( laface.gt.0 ) then
 205 c
 206             nbare2 = 3
 207             do 2211 , iarelo = 1 , nbare2
 208               liare2(iarelo) = aretri(merefa,iarelo)
 209  2211       continue
 210 c
 211           else
 212 c
 213             nbare2 = 4
 214             do 2212 , iarelo = 1 , nbare2
 215               liare2(iarelo) = arequa(merefa,iarelo)
 216  2212       continue
 217 c
 218           endif
 219 c
 220           nbare1 = 0
 221           do 2213 , iaux = 1 , nbare2
 222             if ( decare(liare2(iaux)).eq.0 ) then
 223               nbare1 = nbare1 + 1
 224               liare1(nbare1) = liare2(iaux)
 225             endif
 226  2213     continue
 227 c
 228 c on parcourt les aretes retenues
 229 c
 230           do 220 , iarelo = 1 , nbare1
 231 c
 232             iarete = liare1(iarelo)
 233 c
 234             merear = merare(iarete)
 235 c
 236             if ( merear.ne.0 ) then
 237 c
 238 c 2.2.2. ==> l'arete iarete est sur le bord de la face grdmfa
 239 c            ------------------------------------------------
 240 c               ==> pour toutes les faces qui s'appuient sur merear,
 241 c                   mere de cette arete iarete :
 242 c                 . si elles sont a reactiver, on les garde
 243 c
 244               ideb = posifa(merear-1)+1
 245               ifin = posifa(merear)
 246 c
 247               do 2221 , ipos = ideb , ifin
 248 c
 249                 iface = facare(ipos)
 250 c
 251                 if ( decfac(iface).eq.-1 ) then
 252 c
 253                   decfac(iface) = 0
 254                   if ( iface.gt.0 ) then
 255                     do 2222 , jarelo = 1 , 3
 256                       jarete = aretri(iface,jarelo)
 257                       decare(jarete) = 0
 258  2222               continue
 259                   else
 260                     iaux = -iface
 261                     do 2223 , jarelo = 1 , 4
 262                       jarete = arequa(iaux,jarelo)
 263                       decare(jarete) = 0
 264  2223               continue
 265                   endif
 266 c
 267                 endif
 268 c
 269  2221         continue
 270 c
 271             else
 272 c
 273 c 2.2.3. ==> l'arete iarete est interieure a la face grdmfa
 274 c            ----------------------------------------------
 275 c               ==> pour toutes les faces des tetraedres qui
 276 c                   s'appuient sur le triangle pere grdmfa :
 277 c                 . si elles sont a reactiver, on les garde
 278 c
 279               if ( laface.gt.0 ) then
 280 c
 281                 do 2231 , itetra = 1 , nbtetr
 282 c
 283 c            attention : on ne traite que les volumes traditionnels
 284 c                        tetra ou hexa, d'ou le codret=12
 285             if ( voltri(itetra,grdmfa).lt.0 ) then
 286                codret = 12
 287                goto 33
 288             endif
 289                   tetrae = voltri(itetra,grdmfa)
 290                   if ( tetrae.ne.0 ) then
 291 c
 292                     do 2232 , ifalo = 1 , 4
 293 c
 294                       iface = tritet(tetrae,ifalo)
 295 c
 296                       if ( decfac(iface).eq.-1 ) then
 297 c
 298                         decfac(iface) = 0
 299                         do 2233 , jarelo = 1 , 3
 300                           jarete = aretri(iface,jarelo)
 301                           decare(jarete) = 0
 302  2233                   continue
 303 c
 304                       endif
 305 c
 306  2232               continue
 307 c
 308                   endif
 309 c
 310  2231           continue
 311 c
 312               endif
 313 c
 314             endif
 315 c
 316   220     continue
 317 c
 318         endif
 319 c
 320     2 continue
 321 c
 322 #ifdef _DEBUG_HOMARD_
 323         write (ulsort,*) 'sortie de ',nompro
 324         do 1106 , iaux = 1 , nbquto
 325           write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux)
 326 cgn          write (ulsort,90001) 'quadrangle', iaux,
 327 cgn     >    arequa(iaux,1), arequa(iaux,2),
 328 cgn     >    arequa(iaux,3), arequa(iaux,4)
 329  1106   continue
 330       if ( nbquto.gt.0 ) then
 331         iaux = min(nbquto,5)
 332         write (ulsort,90001) 'quadrangle', iaux,
 333      >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 334      >  decare(arequa(iaux,3)), decare(arequa(iaux,4))
 335         iaux = min(nbquto,8)
 336         write (ulsort,90001) 'quadrangle', iaux,
 337      >  decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 338      >  decare(arequa(iaux,3)), decare(arequa(iaux,4))
 339       endif
 340 #endif
 341 c
 342 c====
 343 c 3. la fin
 344 c====
 345 c
 346    33 continue
 347 c
 348       if ( codret.ne.0 ) then
 349 c
 350 #include "envex2.h"
 351 c
 352       write (ulsort,texte(langue,1)) 'Sortie', nompro
 353       write (ulsort,texte(langue,2)) codret
 354 c
 355       endif
 356 c
 357 #ifdef _DEBUG_HOMARD_
 358       write (ulsort,texte(langue,1)) 'Sortie', nompro
 359       call dmflsh (iaux)
 360 #endif
 361 c
 362       end