src/tool/Decision/derco7.F

   1       subroutine derco7 ( niveau,
   2      >                    decare, decfac,
   3      >                    hetare,
   4      >                    hettri, aretri, nivtri,
   5      >                    voltri,
   6      >                    hetqua, arequa, nivqua,
   7      >                    volqua,
   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 - Raffinement : COntamination - option 7
  30 c                --          -             --                     -
  31 c Complement sur la regle des ecarts de niveau pour du non-conforme
  32 c a 1 noeud pendant par arete
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . niveau . e   .    1   . niveau en cours d'examen                   .
  38 c . decare . es  . nbarto . decisions des aretes                       .
  39 c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
  40 c .        .     . :nbtrto.                                            .
  41 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  42 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  43 c . aretri . e   . nbtrto . numeros des 3 aretes des triangles         .
  44 c . nivtri . e   . nbtrto . niveau des triangles                       .
  45 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  46 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  47 c .        .     .        .   0 : pas de voisin                        .
  48 c .        .     .        . j>0 : tetraedre j                          .
  49 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  50 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  51 c . arequa . e   . nbquto . numeros des 4 aretes des quadrangles       .
  52 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  53 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  54 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  55 c .        .     .        .   0 : pas de voisin                        .
  56 c .        .     .        . j>0 : hexaedre j                           .
  57 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  58 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  59 c . langue . e   .    1   . langue des messages                        .
  60 c .        .     .        . 1 : francais, 2 : anglais                  .
  61 c . codret . es  .    1   . code de retour des modules                 .
  62 c .        .     .        . 0 : pas de probleme                        .
  63 c ______________________________________________________________________
  64 c
  65 c====
  66 c 0. declarations et dimensionnement
  67 c====
  68 c
  69 c 0.1. ==> generalites
  70 c
  71       implicit none
  72       save
  73 c
  74       character*6 nompro
  75       parameter ( nompro = 'DERCO7' )
  76 c
  77 #include "nblang.h"
  78 c
  79 c 0.2. ==> communs
  80 c
  81 #include "envex1.h"
  82 #include "nombar.h"
  83 #include "nombtr.h"
  84 #include "nombqu.h"
  85 #include "nombte.h"
  86 #include "nombhe.h"
  87 c
  88 c 0.3. ==> arguments
  89 c
  90       integer niveau
  91       integer decare(0:nbarto)
  92       integer decfac(-nbquto:nbtrto)
  93       integer hetare(nbarto)
  94       integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto)
  95       integer voltri(2,nbtrto)
  96       integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto)
  97       integer volqua(2,nbquto)
  98 c
  99       integer ulsort, langue, codret
 100 c
 101 c 0.4. ==> variables locales
 102 c
 103       integer laface
 104       integer etatar
 105       integer iaux
 106       integer iarelo, iarete
 107       integer etatfa
 108       integer nbaret, liaret(4)
 109 c
 110       logical loaret, loface
 111 c
 112       integer nbmess
 113       parameter ( nbmess = 30 )
 114       character*80 texte(nblang,nbmess)
 115 c
 116 c 0.5. ==> initialisations
 117 c ______________________________________________________________________
 118 c
 119 c====
 120 c 1. initialisations
 121 c====
 122 c
 123 #include "impr01.h"
 124 c
 125 #ifdef _DEBUG_HOMARD_
 126       write (ulsort,texte(langue,1)) 'Entree', nompro
 127       call dmflsh (iaux)
 128 #endif
 129 c
 130 #ifdef _DEBUG_HOMARD_
 131 #include "impr03.h"
 132 #endif
 133 c
 134 #include "derco1.h"
 135 c
 136 #ifdef _DEBUG_HOMARD_
 137       write (ulsort,texte(langue,12)) niveau
 138 #endif
 139 c
 140       codret = 0
 141 c
 142 c====
 143 c 2. Complements sur la regle des ecarts de niveau
 144 c    on s'interesse aux faces :
 145 c      . du niveau courant
 146 c      . qui sont a decouper : leurs aretes qui seraient a faire
 147 c        reapparaitre sont declarees "a garder"
 148 c      . qui sont a garder : si toutes leurs aretes sont a couper,
 149 c        on coupera la face aussi
 150 c      . qui sont bidimensionnelles
 151 c====
 152 c
 153       do 2 , laface = -nbquto , nbtrto
 154 cgn          write (ulsort,90001) 'decision face', laface,decfac(laface)
 155 c
 156 c 2.1. ==> examen des faces
 157 c
 158         loaret = .false.
 159         loface = .false.
 160 c
 161         nbaret = 0
 162 c
 163         if ( laface.gt.0 ) then
 164 c
 165           if ( nivtri(laface).eq.niveau ) then
 166             if ( decfac(laface).eq.0 ) then
 167               etatfa = mod( hettri(laface) , 10 )
 168               if ( etatfa.eq.0 ) then
 169                 loface = .true.
 170               endif
 171             elseif ( decfac(laface).eq.4 ) then
 172               loaret = .true.
 173             endif
 174             if ( loface ) then
 175               if ( nbteto.gt.0 ) then
 176                 if ( voltri(1,laface).gt.0 ) then
 177                   loface = .false.
 178                 endif
 179               endif
 180             endif
 181             if ( loaret .or. loface ) then
 182               nbaret = 3
 183               do 211 , iarelo = 1 , nbaret
 184                 liaret(iarelo) = aretri(laface,iarelo)
 185   211         continue
 186             endif
 187           endif
 188 c
 189         elseif ( laface.lt.0 ) then
 190 c
 191           iaux = -laface
 192           if ( nivqua(iaux).eq.niveau ) then
 193             if ( decfac(laface).eq.0 ) then
 194               etatfa = mod( hetqua(iaux) , 100 )
 195               if ( etatfa.eq.0 ) then
 196                 loface = .true.
 197               endif
 198             elseif ( decfac(laface).eq.4 ) then
 199               loaret = .true.
 200             endif
 201             if ( loface ) then
 202               if ( nbheto.gt.0 ) then
 203                 if ( volqua(1,iaux).gt.0 ) then
 204                   loface = .false.
 205                 endif
 206               endif
 207             endif
 208             if ( loaret .or. loface ) then
 209               nbaret = 4
 210               do 212 , iarelo = 1 , nbaret
 211                 liaret(iarelo) = arequa(iaux,iarelo)
 212   212         continue
 213             endif
 214           endif
 215 c
 216         endif
 217 c
 218 c 2.2. ==> les aretes sont a garder
 219 c
 220         if ( loaret ) then
 221 c
 222           do 22 , iarelo = 1 , nbaret
 223             iarete = liaret(iarelo)
 224             if ( decare(iarete).eq.-1 ) then
 225               decare(iarete) = 0
 226 #ifdef _DEBUG_HOMARD_
 227       write (ulsort,texte(langue,30))' decare',iarete,decare(iarete),' '
 228 #endif
 229             endif
 230    22     continue
 231 c
 232         endif
 233 c
 234 c 2.3. ==> la face est eventuellement a couper
 235 c
 236         if ( loface ) then
 237 c
 238           iaux = 0
 239           do 23 , iarelo = 1 , nbaret
 240             iarete = liaret(iarelo)
 241             etatar = mod( hetare(iarete) , 10 )
 242             if ( decare(iarete).eq.2 .or. etatar.eq.2 ) then
 243               iaux = iaux + 1
 244             endif
 245    23     continue
 246 c
 247           if ( iaux.eq.nbaret ) then
 248             decfac(laface) = 4
 249 #ifdef _DEBUG_HOMARD_
 250       write (ulsort,texte(langue,30))' decfac',laface,decfac(laface),' '
 251 #endif
 252           endif
 253 c
 254         endif
 255 c
 256     2 continue
 257 c
 258 #ifdef _DEBUG_HOMARD_
 259         write (ulsort,*) 'sortie de ',nompro
 260         do 1106 , iaux = 1 , nbquto
 261           write (ulsort,90001) 'decision quadrangle', iaux,decfac(-iaux)
 262 cgn          write (ulsort,90001) 'quadrangle', iaux,
 263 cgn     >    arequa(iaux,1), arequa(iaux,2),
 264 cgn     >    arequa(iaux,3), arequa(iaux,4)
 265  1106   continue
 266       if ( nbquto.gt.0 ) then
 267          iaux = min(nbquto,5)
 268           write (ulsort,90001) 'quadrangle', iaux,
 269      >    decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 270      >    decare(arequa(iaux,3)), decare(arequa(iaux,4))
 271          iaux = min(nbquto,8)
 272           write (ulsort,90001) 'quadrangle', iaux,
 273      >    decare(arequa(iaux,1)), decare(arequa(iaux,2)),
 274      >    decare(arequa(iaux,3)), decare(arequa(iaux,4))
 275       endif
 276 #endif
 277 c
 278 c====
 279 c 3. la fin
 280 c====
 281 c
 282       if ( codret.ne.0 ) then
 283 c
 284 #include "envex2.h"
 285 c
 286       write (ulsort,texte(langue,1)) 'Sortie', nompro
 287       write (ulsort,texte(langue,2)) codret
 288 c
 289       endif
 290 c
 291 #ifdef _DEBUG_HOMARD_
 292       write (ulsort,texte(langue,1)) 'Sortie', nompro
 293       call dmflsh (iaux)
 294 #endif
 295 c
 296       end