src/tool/Utilitaire/utb11d.F

   1       subroutine utb11d ( nbbloc, option, tabau4,
   2      >                    hetare, somare,
   3      >                    povoso, voisom,
   4      >                    famare, cfaare,
   5      >                    lapile, tabau2,
   6      >                    nublar,
   7      >                    ulbila,
   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 - Bilan sur le maillage - option 11 - phase d
  30 c    --           -                              --         -
  31 c ______________________________________________________________________
  32 c
  33 c    analyse de la connexite des aretes
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . nbbloc .  s  .   1    . nombre de blocs                            .
  39 c . option . e   .   1    . 0 : on prend toutes les aretes             .
  40 c .        .     .        . 1 : on prend les aretes actives de HOMARD  .
  41 c .        .     .        . 2 : on prend les aretes actives du calcul  .
  42 c . tabau4 . e   . nbarto . indicateurs sur les aretes a examiner :    .
  43 c .        .     .        .  0 : on ne traite pas l'arete              .
  44 c .        .     .        . >0 : on traite l'arete                     .
  45 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  46 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  47 c . povoso . e   .0:nbnoto. pointeur des voisins par noeud             .
  48 c . voisom . e   . nvosom . aretes voisines de chaque noeud            .
  49 c . famare . e   . nbarto . famille des aretes                         .
  50 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  51 c .        .     . nbfare .   1 : famille MED                          .
  52 c .        .     .        .   2 : type de segment                      .
  53 c .        .     .        .   3 : orientation                          .
  54 c .        .     .        .   4 : famille d'orientation inverse        .
  55 c .        .     .        .   5 : numero de ligne de frontiere         .
  56 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  57 c .        .     .        . <= 0 si non concernee                      .
  58 c .        .     .        .   6 : famille frontiere active/inactive    .
  59 c .        .     .        .   7 : numero de surface de frontiere       .
  60 c .        .     .        . + l : appartenance a l'equivalence l       .
  61 c . lapile .  a  .   *    . tableau de travail                         .
  62 c . tabau2 .  a  . nbnoto . tableau de travail                         .
  63 c . nublar .  s  . nbarto . numero du bloc pour chaque arete           .
  64 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  65 c .        .     .        . si 0 : on n'ecrit rien                     .
  66 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  67 c . langue . e   .    1   . langue des messages                        .
  68 c .        .     .        . 1 : francais, 2 : anglais                  .
  69 c . codret .  s  .    1   . code de retour des modules                 .
  70 c .        .     .        . 0 : pas de probleme                        .
  71 c .        .     .        . 1 : probleme                               .
  72 c .____________________________________________________________________.
  73 c
  74 c====
  75 c 0. declarations et dimensionnement
  76 c====
  77 c
  78 c 0.1. ==> generalites
  79 c
  80       implicit none
  81       save
  82 c
  83       character*6 nompro
  84       parameter ( nompro = 'UTB11D' )
  85 c
  86 #include "nblang.h"
  87 #include "coftex.h"
  88 c
  89 c 0.2. ==> communs
  90 c
  91 #include "envex1.h"
  92 #include "nbfami.h"
  93 #include "nombno.h"
  94 #include "nombar.h"
  95 c
  96 #include "dicfen.h"
  97 #include "impr02.h"
  98 c
  99 c 0.3. ==> arguments
 100 c
 101       integer nbbloc, option
 102       integer tabau4(nbarto)
 103       integer hetare(nbarto), somare(2,nbarto)
 104       integer povoso(0:nbnoto), voisom(*)
 105       integer famare(nbarto), cfaare(nctfar,nbfare)
 106 c
 107       integer lapile(*)
 108       integer tabau2(nbnoto)
 109       integer nublar(nbarto)
 110 c
 111       integer ulbila
 112       integer ulsort, langue, codret
 113 c
 114 c 0.4. ==> variables locales
 115 c
 116       integer iaux, jaux, kaux, laux, maux, ldeb, lfin
 117       integer larete
 118       integer etat
 119       integer elem, lgpile
 120       integer tabau3(1)
 121       integer tbiaux(1)
 122 c
 123       integer nbmess
 124       parameter (nbmess = 10 )
 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) = '(/,3x,''. Connexite des '',a)'
 142       texte(1,10) = '(''.. Impression du bloc'',i8)'
 143 c
 144       texte(2,4) = '(/,3x,''. Connexity of '',a)'
 145       texte(2,10) = '(''.. Printing of block #'',i8)'
 146 c
 147 #ifdef _DEBUG_HOMARD_
 148       write (ulsort,texte(langue,4)) mess14(langue,3,1)
 149       write (ulsort,*) 'option =', option
 150 #endif
 151 c
 152 c 1.3. ==> Aucun bloc au depart
 153 c
 154       do 13 , iaux = 1 , nbarto
 155         nublar(iaux) = 0
 156    13 continue
 157 c
 158       codret = 0
 159 c
 160 c====
 161 c 2. blocs d'aretes
 162 c====
 163 #ifdef _DEBUG_HOMARD_
 164       write (ulsort,*) '2. blocs d''aretes ; codret =', codret
 165 #endif
 166 c
 167       nbbloc = 0
 168       lgpile = 0
 169 c
 170       do 22 , larete = 1 , nbarto
 171 c
 172 #ifdef _DEBUG_HOMARD_
 173       write (ulsort,*) 'Debut boucle 22, avant le bloc',nbbloc+1,
 174      >', larete =', larete, tabau4(larete)
 175 #endif
 176 c
 177 c       On examine les aretes presentes dans la liste transmise
 178 c
 179         if ( tabau4(larete).eq.1 ) then
 180 c
 181 c       On examine les faces qui ne sont pas deja dans un bloc
 182 c
 183         if ( nublar(larete).eq.0 ) then
 184 c
 185 #ifdef _DEBUG_HOMARD_
 186         write (ulsort,*) 'larete =', larete,
 187      > ', etat =', hetare(larete),
 188      > ', type =',cfaare(cotyel,famare(larete))
 189 #endif
 190 c
 191         if ( option.gt.0 ) then
 192 c
 193           etat = mod( hetare(larete) , 10 )
 194           if ( option.gt.1 ) then
 195             if ( cfaare(cotyel,famare(larete)).eq.0 ) then
 196               etat = -9999
 197             endif
 198           endif
 199 c
 200         else
 201 c
 202           etat = 0
 203 c
 204         endif
 205 c
 206         if ( etat.eq.0 ) then
 207 c
 208 c 2.1. ==> on commence un nouveau bloc :
 209 c 2.1.1. ==> impression des caracteristiques du bloc precedent
 210 c
 211           if ( ulbila.gt.0 .and. nbbloc.ge.1 ) then
 212 c
 213 c 2.1.1.1. ==> recherche des noeuds de ce bloc
 214 c
 215             if ( codret.eq.0 ) then
 216 c
 217             iaux = 1
 218 #ifdef _DEBUG_HOMARD_
 219       write (ulsort,texte(langue,3)) 'UTB11E', nompro
 220 #endif
 221             call utb11e ( iaux, nbbloc, nublar,
 222      >                    somare,
 223      >                    tbiaux, tbiaux,
 224      >                    tbiaux, tbiaux, tbiaux, tbiaux,
 225      >                      jaux,   jaux,   jaux,   jaux,
 226      >                    tabau2, tabau4,
 227      >                    ulsort, langue, codret )
 228 c
 229             endif
 230 c
 231 c 2.1.1.2. ==> impression veritable
 232 c
 233             if ( codret.eq.0 ) then
 234 c
 235 #ifdef _DEBUG_HOMARD_
 236       write (ulsort,texte(langue,10)) nbbloc
 237       write (ulsort,*) nublar
 238 #endif
 239 c
 240             jaux = 0
 241             kaux = 1
 242 #ifdef _DEBUG_HOMARD_
 243       write (ulsort,texte(langue,3)) 'UTB11F', nompro
 244 #endif
 245             call utb11f ( nbbloc, jaux, kaux, kaux,
 246      >                    nublar, tabau2, tabau3, tabau4,
 247      >                    ulbila,
 248      >                    ulsort, langue, codret )
 249 c
 250             endif
 251 c
 252           endif
 253 c
 254 c 2.1.2. ==> initialisations
 255 c
 256           nbbloc = nbbloc + 1
 257           elem = larete
 258 #ifdef _DEBUG_HOMARD_
 259       write (ulsort,*) 'debut du bloc ',nbbloc,' avec elem = ', elem
 260 #endif
 261 c
 262    21     continue
 263 c
 264 #ifdef _DEBUG_HOMARD_
 265 cgn      write (ulsort,*) 'bloc ',nbbloc,' avec elem = ', elem
 266 #endif
 267 c
 268 c 2.2. ==> memorisation du bloc pour l'element courant
 269 c
 270           nublar(elem) = nbbloc
 271 cgn          print *,'elem,nbbloc ',elem, nbbloc
 272 c
 273 c 2.3. ==> mise des voisins dans la pile
 274 c
 275           do 222 , iaux = 1 , 2
 276 c
 277 c 2.3.1. ==> reperage des voisins de elem par son iaux-ieme sommet
 278 c
 279             jaux = somare(iaux,elem)
 280             ldeb = povoso(jaux-1)+1
 281             lfin = povoso(jaux)
 282 c
 283 c 2.3.2. ==> examen des voisins
 284 c
 285             do 2221 , laux = ldeb, lfin
 286 c
 287               kaux = voisom(laux)
 288               if ( nublar(kaux).eq.0 ) then
 289 c
 290                 if ( tabau4(kaux).eq.1 ) then
 291                   if ( option.gt.0 ) then
 292                     etat = mod( hetare(kaux) , 10 )
 293 cgn        write (ulsort,*) kaux,' : etat = ', etat,
 294 cgn     > ',  type =',cfaare(cotyel,famare(kaux))
 295                     if ( option.gt.1 ) then
 296                       if ( cfaare(cotyel,famare(kaux)).eq.0 ) then
 297                         etat = -2221
 298                       endif
 299                     endif
 300                   else
 301                     etat = 0
 302                   endif
 303 cgn                print *,'==> etat ',etat
 304                   if ( etat.eq.0 ) then
 305                     do 2222 , maux = 1 , lgpile
 306                     if ( lapile(maux).eq.kaux ) then
 307                       goto 2221
 308                     endif
 309  2222             continue
 310 cgn        write (ulsort,*) '==> ajout de', kaux
 311                   lgpile = lgpile + 1
 312                   lapile(lgpile) = kaux
 313 #ifdef _DEBUG_HOMARD_
 314       write (ulsort,1789) (lapile(maux), maux = 1 , lgpile)
 315  1789 format(10i5)
 316 #endif
 317                   endif
 318                 endif
 319 c
 320               endif
 321 c
 322  2221       continue
 323 c
 324   222     continue
 325 c
 326 c 2.4. ==> on passe a l'element suivant de la pile
 327 c
 328           if ( lgpile.gt.0 ) then
 329 c
 330             elem = lapile(lgpile)
 331             lgpile = lgpile - 1
 332             goto 21
 333 c
 334           endif
 335 #ifdef _DEBUG_HOMARD_
 336       write (ulsort,*) 'fin du bloc', nbbloc
 337 #endif
 338 c
 339         endif
 340 c
 341         endif
 342 c
 343 c 2.5. ==> on continue la liste des aretes en prevision d'un eventuel
 344 c          nouveau bloc
 345 c
 346         endif
 347 c
 348    22 continue
 349 c
 350 c====
 351 c 3. impression du dernier bloc
 352 c====
 353 #ifdef _DEBUG_HOMARD_
 354       write(ulsort,*) '3. impression dernier bloc ; codret = ', codret
 355 #endif
 356 c
 357       if ( codret.eq.0 ) then
 358 c
 359       if ( ulbila.gt.0 .and. nbbloc.gt.0 ) then
 360 c
 361 c 3.1. ==> recherche des noeuds de ce bloc
 362 c
 363         if ( codret.eq.0 ) then
 364 c
 365          iaux = 1
 366 #ifdef _DEBUG_HOMARD_
 367       write (ulsort,texte(langue,3)) 'UTB11E', nompro
 368 #endif
 369          call utb11e ( iaux, nbbloc, nublar,
 370      >                 somare,
 371      >                 tbiaux, tbiaux,
 372      >                 tbiaux, tbiaux, tbiaux, tbiaux,
 373      >                   jaux,   jaux,   jaux,   jaux,
 374      >                 tabau2, tabau4,
 375      >                 ulsort, langue, codret )
 376 c
 377         endif
 378 c
 379 c 3.2. ==> impression veritable
 380 c
 381         if ( codret.eq.0 ) then
 382 c
 383 #ifdef _DEBUG_HOMARD_
 384       write (ulsort,texte(langue,10)) nbbloc
 385 cgn      write (ulsort,*) nublar
 386 #endif
 387 c
 388         endif
 389 c
 390         if ( nbbloc.eq.1 ) then
 391           iaux = -nbbloc
 392         else
 393           iaux =  nbbloc
 394         endif
 395         jaux = 0
 396         kaux = 1
 397 #ifdef _DEBUG_HOMARD_
 398       write (ulsort,texte(langue,3)) 'UTB11F', nompro
 399 #endif
 400         call utb11f ( iaux, jaux, kaux, kaux,
 401      >                nublar, tabau2, tabau3, tabau4,
 402      >                ulbila,
 403      >                ulsort, langue, codret )
 404 c
 405         write (ulbila,3000)
 406  3000   format(5x,58('*'))
 407 c
 408       endif
 409 c
 410       endif
 411 c
 412 c====
 413 c 4. la fin
 414 c====
 415 c
 416       if ( codret.ne.0 ) then
 417 c
 418 #include "envex2.h"
 419 c
 420       write (ulsort,texte(langue,1)) 'Sortie', nompro
 421       write (ulsort,texte(langue,2)) codret
 422 c
 423       endif
 424 c
 425 #ifdef _DEBUG_HOMARD_
 426       write (ulsort,texte(langue,1)) 'Sortie', nompro
 427       call dmflsh (iaux)
 428 #endif
 429 c
 430       end