src/tool/Decision/decr02.F

   1       subroutine decr02 ( decfac, decare,
   2      >                    somare,
   3      >                    filare, merare, hetare,
   4      >                    posifa, facare,
   5      >                    hettri, aretri, nivtri,
   6      >                    voltri,
   7      >                    hetqua, arequa, nivqua,
   8      >                    list1f, bornoe, borare, list2f,
   9      >                    afaire,
  10      >                    ulsort, langue, codret )
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c
  31 c traitement des DEcisions - Contraintes de Raffinement - 02
  32 c                --          -              -             --
  33 c    Decalage de deux mailles avant un changement de niveau
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
  39 c .        .     . :nbtrto.                                            .
  40 c . decare . es  . nbarto . decisions des aretes                       .
  41 c . somare . e   .nbarto*2. numeros des extremites d'arete             .
  42 c . filare . e   . nbarto . fille ainee de chaque arete                .
  43 c . merare . e   . nbarto . mere de chaque arete                       .
  44 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  45 c . posifa . e   . nbarto . pointeur sur tableau facare                .
  46 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  47 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  48 c . aretri . e   .nbtrto*3. numeros des 3 aretes 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*4. numeros des 4 aretes des quadrangles       .
  57 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  58 c . list1f . aux . nbquto/. auxiliaire sur les faces (quad. + tri.)    .
  59 c .        .     . nbtrto .                                            .
  60 c . bornoe . aux . nbnoto . auxiliaire sur les noeuds                  .
  61 c . borare . aux . nbarto . auxiliaire sur les aretes                  .
  62 c . afaire . es  .    1   . que faire a la sortie                      .
  63 c .        .     .        . 0 : aucune action                          .
  64 c .        .     .        . 1 : refaire une iteration de l'algorithme  .
  65 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  66 c . langue . e   .    1   . langue des messages                        .
  67 c .        .     .        . 1 : francais, 2 : anglais                  .
  68 c . codret . es  .    1   . code de retour des modules                 .
  69 c .        .     .        . 0 : pas de probleme                        .
  70 c .        .     .        . sinon : probleme                           .
  71 c ______________________________________________________________________
  72 c
  73 c====
  74 c 0. declarations et dimensionnement
  75 c====
  76 c
  77 c 0.1. ==> generalites
  78 c
  79       implicit none
  80       save
  81 c
  82       character*6 nompro
  83       parameter ( nompro = 'DECR02' )
  84 c
  85 #include "nblang.h"
  86 c
  87 c 0.2. ==> communs
  88 c
  89 #include "envex1.h"
  90 c
  91 #include "nombno.h"
  92 #include "nombar.h"
  93 #include "nombtr.h"
  94 #include "nombqu.h"
  95 #include "nombte.h"
  96 #include "impr02.h"
  97 #include "ope1a4.h"
  98 c
  99 c 0.3. ==> arguments
 100 c
 101       integer decfac(-nbquto:nbtrto), decare(0:nbarto)
 102       integer somare(2,nbarto)
 103       integer hetare(nbarto), filare(nbarto), merare(nbarto)
 104       integer posifa(0:nbarto), facare(nbfaar)
 105       integer hettri(nbtrto), aretri(nbtrto,3), nivtri(nbtrto)
 106       integer voltri(2,nbtrto)
 107       integer hetqua(nbquto), arequa(nbquto,4), nivqua(nbquto)
 108       integer list1f(2,*), bornoe(*), borare(*), list2f(*)
 109       integer afaire
 110 c
 111       integer ulsort, langue, codret
 112 c
 113 c 0.4. ==> variables locales
 114 c
 115       integer ipos
 116       integer iaux, ideb, ifin
 117       integer laface, faced, etatfa
 118       integer larelo, lardeb, larfin, larete, iface
 119       integer option, nbento, nbaret
 120       integer nbfac1, nbfac2
 121       integer nbnobo, nbar2d, nbar3d
 122 c
 123       integer nbmess
 124       parameter ( nbmess = 30 )
 125       character*80 texte(nblang,nbmess)
 126 c
 127 c 0.5. ==> initialisations
 128 c ______________________________________________________________________
 129 c
 130 c====
 131 c 1. messages
 132 c====
 133 c
 134 #include "impr01.h"
 135 c
 136 #ifdef _DEBUG_HOMARD_
 137       write (ulsort,texte(langue,1)) 'Entree', nompro
 138       call dmflsh (iaux)
 139 #endif
 140 c
 141       texte(1,4) = '(5x,''Au moins 2 mailles entre 2 niveaux.'')'
 142       texte(1,5) = '(7x,''Nombre de faces a reconsiderer :'',i6,/)'
 143 c
 144       texte(2,4) = '(5x,''A least 2 meshes between 2 levels.'')'
 145       texte(2,5) = '(7x,''Number of faces to deal with :'',i6,/)'
 146 c
 147 #include "impr03.h"
 148 c
 149 #include "derco1.h"
 150 c
 151       codret = 0
 152 c
 153       write (ulsort,texte(langue,4))
 154 c
 155 c====
 156 c 2. recherche des noeuds a la limite entre deux zones de raffinement de
 157 c    niveau different, sans tenir compte du bord exterieur
 158 c====
 159 c
 160       if ( codret.eq.0 ) then
 161 c
 162       iaux = 3
 163 #ifdef _DEBUG_HOMARD_
 164       write (ulsort,texte(langue,3)) 'UTBONO', nompro
 165 #endif
 166       call utbono ( iaux,
 167      >              nbnoto, nbarto, nbtrto, nbquto, nbteto, nbfaar,
 168      >              somare,
 169      >              filare, hetare,
 170      >              posifa, facare,
 171      >              hettri, aretri, voltri,
 172      >              hetqua, arequa,
 173      >              nbnobo, bornoe,
 174      >              ulsort, langue, codret )
 175 c
 176       endif
 177 c
 178 c====
 179 c 3. recherche des aretes a la limite entre deux zones de raffinement de
 180 c    niveau different, sans tenir compte du bord exterieur
 181 c====
 182 #ifdef _DEBUG_HOMARD_
 183       write (ulsort,90002) '3. recherche aretes ; codret', codret
 184 #endif
 185 c
 186       if ( codret.eq.0 ) then
 187 c
 188       iaux = 3
 189 #ifdef _DEBUG_HOMARD_
 190       write (ulsort,texte(langue,3)) 'UTBOAR', nompro
 191 #endif
 192       call utboar ( iaux,
 193      >              nbarto, nbtrto, nbquto, nbteto, nbfaar,
 194      >              hetare, filare,
 195      >              posifa, facare,
 196      >              aretri, hettri, voltri,
 197      >              arequa, hetqua,
 198      >              nbar2d, nbar3d, borare,
 199      >              ulsort, langue, codret )
 200 c
 201       endif
 202 c
 203 c====
 204 c 4. recherche des faces :
 205 c    . dont une des aretes est a la limite entre deux zones de
 206 c      raffinement de niveau different, sans tenir compte du bord
 207 c      exterieur
 208 c    . qui sont actives
 209 c    . qui sont a garder dans l'adaptation
 210 c====
 211 #ifdef _DEBUG_HOMARD_
 212       write (ulsort,90002) '4. recherche faces ; codret', codret
 213 #endif
 214 c
 215       if ( codret.eq.0 ) then
 216 c
 217       nbfac1 = 0
 218 c
 219       do 4 , option = 2, 4, 2
 220 c
 221 #ifdef _DEBUG_HOMARD_
 222         write (ulsort,*) mess14(langue,2,option)
 223 #endif
 224 c
 225         if ( option.eq.2 ) then
 226           nbento = nbtrto
 227           nbaret = 3
 228         else
 229           nbento = nbquto
 230           nbaret = 4
 231        endif
 232 c
 233         do 40 , laface = 1 , nbento
 234 c
 235           if ( option.eq.2 ) then
 236             etatfa = mod( hettri(laface) , 10 )
 237             faced = laface
 238           else
 239             etatfa = mod( hetqua(laface) , 100 )
 240             faced = -laface
 241           endif
 242 c
 243           if ( etatfa.eq.0 .and. decfac(faced).eq.0 ) then
 244 c
 245             do 41 , larelo = 1 , nbaret
 246 c
 247               if ( option.eq.2 ) then
 248                 larete = aretri(laface,larelo)
 249               else
 250                 larete = arequa(laface,larelo)
 251               endif
 252               if ( borare(larete).eq.1 ) then
 253                 nbfac1 = nbfac1 + 1
 254                 list1f(1,nbfac1) = faced
 255                 list1f(2,nbfac1) = larelo
 256                 goto 40
 257               endif
 258 c
 259    41       continue
 260 c
 261           endif
 262 c
 263    40   continue
 264 c
 265     4 continue
 266 c
 267       endif
 268 cgn      write (ulsort,1789)(list1f(1,iaux),list1f(2,iaux),
 269 cgn     >iaux=1,nbfac1)
 270 cgn 1789 format(10(i8,i2))
 271 c
 272 c====
 273 c 5. pour chacune des faces trouvees a l'etape 4 :
 274 c    . on cherche leur voisine par l'arete parallele au bord
 275 c    . si cette voisine est a couper en 4, on coupera la face
 276 c====
 277 #ifdef _DEBUG_HOMARD_
 278       write (ulsort,90002) '5. voisines ; codret', codret
 279 #endif
 280 c
 281       if ( codret.eq.0 ) then
 282 c
 283       nbfac2 = 0
 284 c
 285       do 5 , iaux = 1 , nbfac1
 286 c
 287         faced = list1f(1,iaux)
 288         if ( faced.gt.0 ) then
 289           lardeb = 1
 290           larfin = 3
 291         else
 292           lardeb = per1a4(2,list1f(2,iaux))
 293           larfin = lardeb
 294         endif
 295 c
 296         do 51 , larelo = lardeb , larfin
 297 c
 298           if ( faced.gt.0 ) then
 299             larete = aretri(faced,larelo)
 300           else
 301             larete = arequa(-faced,larelo)
 302           endif
 303 c
 304           if ( decare(larete).eq.2 ) then
 305 c
 306             ideb = posifa(larete-1)+1
 307             ifin = posifa(larete)
 308 c
 309             do 511 , ipos = ideb , ifin
 310               iface = facare(ipos)
 311               if ( iface.ne.faced) then
 312                 if ( decfac(iface).eq.4 ) then
 313                   nbfac2 = nbfac2 + 1
 314                   list2f(nbfac2) = faced
 315                 endif
 316               endif
 317   511       continue
 318 c
 319           endif
 320 c
 321    51   continue
 322 c
 323     5 continue
 324 c
 325       endif
 326 c
 327 c====
 328 c 6. modifications des decisions des faces
 329 c====
 330 #ifdef _DEBUG_HOMARD_
 331       write (ulsort,90002) '6. modifications decfac ; codret', codret
 332 #endif
 333 c
 334       if ( codret.eq.0 ) then
 335 c
 336       if ( nbfac2.gt.0 ) then
 337         write (ulsort,texte(langue,5)) nbfac2
 338         afaire = 1
 339       endif
 340 c
 341       do 61 , iaux = 1 , nbfac2
 342 c
 343         laface = list2f(iaux)
 344 #ifdef _DEBUG_HOMARD_
 345         write (ulsort,texte(langue,30)) 'decfac',laface,4,' '
 346 #endif
 347         decfac(laface) = 4
 348 c
 349         if ( laface.gt.0 ) then
 350           nbaret = 3
 351         else
 352           nbaret = 4
 353         endif
 354 c
 355         do 611 , larelo = 1 , nbaret
 356 c
 357           if ( laface.gt.0 ) then
 358             larete = aretri(laface,larelo)
 359           else
 360             larete = arequa(-laface,larelo)
 361           endif
 362 c
 363           if ( decare(larete).eq.0 ) then
 364             if ( mod(hetare(larete),10).eq.0 ) then
 365               decare(larete) = 2
 366             endif
 367           elseif ( decare(larete).eq.-1 ) then
 368             decare(larete) = 0
 369           endif
 370 #ifdef _DEBUG_HOMARD_
 371       write (ulsort,texte(langue,30))'decare', larete,decare(larete),' '
 372 #endif
 373 c
 374   611   continue
 375 c
 376    61 continue
 377 c
 378       endif
 379 c
 380 c====
 381 c 7. la fin
 382 c====
 383 c
 384       if ( codret.ne.0 ) then
 385 c
 386 #include "envex2.h"
 387 c
 388       write (ulsort,texte(langue,1)) 'Sortie', nompro
 389       write (ulsort,texte(langue,2)) codret
 390 c
 391       endif
 392 c
 393 #ifdef _DEBUG_HOMARD_
 394       write (ulsort,texte(langue,1)) 'Sortie', nompro
 395       call dmflsh (iaux)
 396 #endif
 397 c
 398       end