src/tool/Utilitaire/utboar.F

   1       subroutine utboar ( choix,
   2      >                    nbarto, nbtrto, nbquto, nbteto, nbfaar,
   3      >                    hetare, filare,
   4      >                    posifa, facare,
   5      >                    aretri, hettri, voltri,
   6      >                    arequa, hetqua,
   7      >                    nbar2d, nbar3d, borare,
   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    UTilitaire - BOrd - ARetes
  30 c    --           --     --
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . choix  . e   .   1    . choix du travail a faire                   .
  36 c .        .     .        . 1 : les aretes du bord du domaine          .
  37 c .        .     .        . 2 : les aretes a la limite entre deux zones.
  38 c .        .     .        .     de raffinement de niveau different     .
  39 c .        .     .        . 3 : idem mais en ignorant le bord exterieur.
  40 c . nbarto . e   .   1    . nombre d'aretes total                      .
  41 c . nbtrto . e   .   1    . nombre de triangles total                  .
  42 c . nbquto . e   .   1    . nombre de quadrangles total                .
  43 c . nbteto . e   .   1    . nombre de tetraedres total                 .
  44 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  45 c . filare . e   . nbarto . fille ainee de chaque arete                .
  46 c . posifa . e   .0:nbarto. pointeur sur tableau facare                .
  47 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  48 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  49 c . hettri . e   . nbtrto . historique de l'etat 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 . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  56 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  57 c . nbar2d .  s  .   1    . nombre d'aretes de bord 2D                 .
  58 c . nbar3d .  s  .   1    . nombre d'aretes de bord 3D                 .
  59 c . borare .  s  . nbarto . reperage des aretes de bord                .
  60 c .        .     .        . avec le choix 1 (aretes du bord du domaine).
  61 c .        .     .        . 0 : l'arete est interne au domaine         .
  62 c .        .     .        . 1 : l'arete borde une region 2D            .
  63 c .        .     .        . 2 : l'arete borde une region 3D            .
  64 c .        .     .        . avec le choix 3 (aretes du bord du domaine).
  65 c .        .     .        . 0 : l'arete est interne au domaine         .
  66 c .        .     .        . 1 : l'arete borde une region 2D            .
  67 c .        .     .        . 2 : l'arete borde une region 3D            .
  68 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  69 c . langue . e   .    1   . langue des messages                        .
  70 c .        .     .        . 1 : francais, 2 : anglais                  .
  71 c . codret . es  .    1   . code de retour des modules                 .
  72 c .        .     .        . 0 : pas de probleme                        .
  73 c .        .     .        . sinon : probleme                           .
  74 c ______________________________________________________________________
  75 c
  76 c====
  77 c 0. declarations et dimensionnement
  78 c====
  79 c
  80 c 0.1. ==> generalites
  81 c
  82       implicit none
  83       save
  84 c
  85       character*6 nompro
  86       parameter ( nompro = 'UTBOAR' )
  87 c
  88 #include "nblang.h"
  89 c
  90 c 0.2. ==> communs
  91 c
  92 #include "envex1.h"
  93 c
  94 #include "impr02.h"
  95 c
  96 c 0.3. ==> arguments
  97 c
  98       integer choix
  99       integer nbarto, nbtrto, nbquto, nbteto, nbfaar
 100       integer hetare(nbarto), filare(nbarto)
 101       integer posifa(0:nbarto), facare(nbfaar)
 102       integer aretri(nbtrto,3), hettri(nbtrto)
 103       integer voltri(2,nbtrto)
 104       integer arequa(nbquto,4), hetqua(nbquto)
 105       integer nbar2d, nbar3d, borare(nbarto)
 106 c
 107       integer ulsort, langue, codret
 108 c
 109 c 0.4. ==> variables locales
 110 c
 111       integer iaux, jaux
 112       integer ideb, ifin
 113       integer larete, laface
 114       integer nbfact
 115 #ifdef _DEBUG_HOMARD_
 116       integer glop
 117 #endif
 118 c
 119       logical aubord
 120 c
 121       integer nbmess
 122       parameter ( nbmess = 10 )
 123       character*80 texte(nblang,nbmess)
 124 c ______________________________________________________________________
 125 c
 126 c====
 127 c 1. messages
 128 c====
 129 c
 130 #include "impr01.h"
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133       write (ulsort,texte(langue,1)) 'Entree', nompro
 134       call dmflsh (iaux)
 135 #endif
 136 c
 137       texte(1,4) = '(''Nombre d''''aretes de bord '',i1,''D :'',i10)'
 138       texte(1,5) = '(''Traitement des '',a)'
 139       texte(1,6) = '(a,''.. Examen du '',a,''numero '',i10)'
 140 c
 141       texte(2,4) = '(''Number of '',i1,''D boundary edges :'',i10)'
 142       texte(2,5) = '(''Treatment of '',a)'
 143       texte(2,6) = '(a,''.. Examination of '',a,'',# '',i10)'
 144 c
 145 #include "impr03.h"
 146 c
 147 #ifdef _DEBUG_HOMARD_
 148       write (ulsort,90002) 'choix', choix
 149 #endif
 150 c
 151       codret = 0
 152 c
 153 c====
 154 c 2. initialisations : tout est interne
 155 c====
 156 c
 157       do 20 , larete = 1, nbarto
 158         borare(larete) = 0
 159    20 continue
 160 c
 161 c====
 162 c 3. recherche des aretes de bords du domaine
 163 c====
 164 c
 165       if ( choix.eq.1 ) then
 166 c
 167 c 3.1. ==> les 3 aretes d'un triangle qui borde un tetraedre et un seul
 168 c          sont de bord. c'est le bord du domaine volumique.
 169 c
 170         if ( nbteto.ne.0 ) then
 171 c
 172           do 31 , laface = 1, nbtrto
 173             if ( voltri(1,laface).lt.0 .or. voltri(2,laface).lt.0) then
 174                codret = 12
 175                goto 66
 176             endif
 177             if ( voltri(1,laface).ne.0 .and.
 178      >           voltri(2,laface).eq.0 ) then
 179               borare(aretri(laface,1)) = 2
 180               borare(aretri(laface,2)) = 2
 181               borare(aretri(laface,3)) = 2
 182             endif
 183    31     continue
 184 c
 185         endif
 186 c
 187 c 3.2. ==> chaque arete qui ne borde qu'une face est de bord. c'est
 188 c          le bord du domaine surfacique.
 189 c
 190         do 32 , larete = 1, nbarto
 191 c
 192           if ( posifa(larete-1)+1 .eq. posifa(larete) ) then
 193             borare(larete) = 1
 194           endif
 195 c
 196    32   continue
 197 c
 198       endif
 199 c
 200 c====
 201 c 4. recherche des aretes de bords des zones de differents niveaux
 202 c====
 203 c
 204 #ifdef _DEBUG_HOMARD_
 205       write (ulsort,90002) '4. recherche ; codret', codret
 206 #endif
 207 c
 208       if ( choix.eq.2 .or. choix.eq.3 ) then
 209 c
 210         do 41 , larete = 1 , nbarto
 211 c
 212           aubord = .false.
 213 c
 214 #ifdef _DEBUG_HOMARD_
 215         if ( larete.eq.-12) then
 216           glop = 1
 217         else
 218           glop = 0
 219         endif
 220 #endif
 221 c
 222 c       On s'interesse aux aretes coupees en 2
 223 c
 224             jaux = mod(hetare(larete),10)
 225             if ( ( jaux.eq.2 ) .or. ( jaux.eq.9 ) ) then
 226 c
 227 c 4.1. ==> Si l'arete a ete reperee au bord par sa mere, on le progage
 228 c          directement aux filles
 229 c
 230             if ( borare(larete).gt.0 ) then
 231 c
 232               aubord = .true.
 233 c
 234             else
 235 c
 236 c 4.2. ==> Sinon, on fait l'analyse.
 237 c
 238 #ifdef _DEBUG_HOMARD_
 239         if ( glop.ne.0 ) then
 240         write (ulsort,texte(langue,6)) ' ', mess14(langue,1,1), larete
 241         endif
 242 #endif
 243 c
 244 c 4.2.1. ==> decompte du nombre de faces actives voisines de cette arete
 245 c
 246               ideb = posifa(larete-1) + 1
 247               ifin = posifa(larete)
 248               nbfact = 0
 249               do 421 , iaux = ideb, ifin
 250 c
 251                 laface = facare(iaux)
 252                 if ( laface.gt.0 ) then
 253                   if ( mod(hettri(laface),10).eq.0 ) then
 254                     nbfact = nbfact + 1
 255                   endif
 256                 else
 257                   if ( mod(hetqua(-laface),100).eq.0 ) then
 258                     nbfact = nbfact + 1
 259                   endif
 260                 endif
 261 #ifdef _DEBUG_HOMARD_
 262           if ( glop.ne.0 ) then
 263               if ( laface.gt.0 ) then
 264                 jaux = 2
 265               else
 266                 jaux = 4
 267               endif
 268           write (ulsort,texte(langue,6)) ' ..',
 269      >          mess14(langue,1,jaux), abs(laface)
 270           endif
 271 #endif
 272 c
 273   421         continue
 274 c
 275 c 4.2.2. ==> Si au moins une face est active et qu'au moins une autre
 276 c            est coupee, c'est que l'arete est a une limite de niveau
 277 c
 278 #ifdef _DEBUG_HOMARD_
 279         if ( glop.ne.0 ) then
 280         write (ulsort,90002) '. nbfact', nbfact
 281         write (ulsort,90002) '. nbfdec', ifin-ideb+1-nbfact
 282         endif
 283 #endif
 284 c
 285               if ( nbfact.ge.(choix-2) ) then
 286 c
 287                 iaux = ifin - ideb + 1 - nbfact
 288                 if ( iaux.ge.1 ) then
 289                   aubord = .true.
 290                 endif
 291 c
 292               endif
 293 c
 294             endif
 295 c
 296           endif
 297 c
 298 c 4.3. ==> enregistrement des deux filles
 299 c
 300           if ( aubord ) then
 301 c
 302             do 43 , jaux = 0, 1
 303 #ifdef _DEBUG_HOMARD_
 304         if ( glop.ne.0 ) then
 305         write (ulsort,90002) '.. reperage de l''arete',
 306      >                       filare(larete)+jaux
 307         endif
 308 #endif
 309               borare(filare(larete)+jaux) = 1
 310    43       continue
 311 c
 312           endif
 313 c
 314    41   continue
 315 c
 316       endif
 317 c
 318 c====
 319 c 5. decompte des aretes de bords
 320 c====
 321 c
 322 #ifdef _DEBUG_HOMARD_
 323       write (ulsort,90002) '5. decompte ; codret', codret
 324 #endif
 325 c
 326       if ( codret.eq.0 ) then
 327 c
 328       nbar2d = 0
 329       nbar3d = 0
 330       do 50 , larete = 1, nbarto
 331         if ( borare(larete).eq.1 ) then
 332           nbar2d = nbar2d + 1
 333         elseif ( borare(larete).eq.2 ) then
 334           nbar3d = nbar3d + 1
 335         endif
 336    50 continue
 337 c
 338       endif
 339 c
 340 c====
 341 c 6. la fin
 342 c====
 343 c
 344    66 continue
 345 c
 346 #ifdef _DEBUG_HOMARD_
 347       write(ulsort,texte(langue,4)) 2, nbar2d
 348       write(ulsort,texte(langue,4)) 3, nbar3d
 349 #endif
 350 c
 351       if ( codret.ne.0 ) then
 352 c
 353 #include "envex2.h"
 354 c
 355       write (ulsort,texte(langue,1)) 'Sortie', nompro
 356       write (ulsort,texte(langue,2)) codret
 357 c
 358       endif
 359 c
 360 #ifdef _DEBUG_HOMARD_
 361       write (ulsort,texte(langue,1)) 'Sortie', nompro
 362       call dmflsh (iaux)
 363 #endif
 364 c
 365       end