src/tool/Utilitaire/utb11c.F

   1       subroutine utb11c ( nbbloc, option, tabau4,
   2      >                    hetare, somare,
   3      >                    hettri, aretri,
   4      >                    hetqua, arequa,
   5      >                    povoso, voisom,
   6      >                    posifa, facare,
   7      >                    famare, cfaare,
   8      >                    famtri, cfatri,
   9      >                    famqua, cfaqua,
  10      >                    lapile, tabau2, tabau3,
  11      >                    taba15, taba16,
  12      >                    nublfa,
  13      >                    ulbila,
  14      >                    ulsort, langue, codret )
  15 c ______________________________________________________________________
  16 c
  17 c                             H O M A R D
  18 c
  19 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  20 c
  21 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  22 c aupres des huissiers de justice Simart et Lavoir a Clamart
  23 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  24 c aupres des huissiers de justice
  25 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  26 c
  27 c    HOMARD est une marque deposee d'Electricite de France
  28 c
  29 c Copyright EDF 1996
  30 c Copyright EDF 1998
  31 c Copyright EDF 2002
  32 c Copyright EDF 2020
  33 c ______________________________________________________________________
  34 c
  35 c    UTilitaire - Bilan sur le maillage - option 11 - phase c
  36 c    --           -                              --         -
  37 c ______________________________________________________________________
  38 c
  39 c    analyse de la connexite des faces
  40 c ______________________________________________________________________
  41 c .        .     .        .                                            .
  42 c .  nom   . e/s . taille .           description                      .
  43 c .____________________________________________________________________.
  44 c . nbbloc .  s  .   1    . nombre de blocs                            .
  45 c . option . e   .   1    . 0 : on prend toutes les faces              .
  46 c .        .     .        . 1 : on prend les faces actives de HOMARD   .
  47 c .        .     .        . 2 : on prend les faces actives du calcul   .
  48 c . tabau4 . e   .-nbquto . indicateurs sur les faces a examiner :     .
  49 c .        .     . :nbtrto.  0 : on ne traite pas la face              .
  50 c .        .     .        . >0 : on traite la face                     .
  51 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  52 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  53 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  54 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  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 . povoso . e   .0:nbnoto. pointeur des voisins par noeud             .
  58 c . voisom . e   . nvosom . aretes voisines de chaque noeud            .
  59 c . posifa . e   .0:nbarto. pointeur sur tableau facare                .
  60 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  61 c . famare . e   . nbarto . famille des aretes                         .
  62 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  63 c .        .     . nbfare .   1 : famille MED                          .
  64 c .        .     .        .   2 : type de segment                      .
  65 c .        .     .        .   3 : orientation                          .
  66 c .        .     .        .   4 : famille d'orientation inverse        .
  67 c .        .     .        .   5 : numero de ligne de frontiere         .
  68 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  69 c .        .     .        . <= 0 si non concernee                      .
  70 c .        .     .        .   6 : famille frontiere active/inactive    .
  71 c .        .     .        .   7 : numero de surface de frontiere       .
  72 c .        .     .        . + l : appartenance a l'equivalence l       .
  73 c . famtri . e   . nbtrto . famille des triangles                      .
  74 c . cfatri . e   . nctftr*. codes des familles des triangles           .
  75 c .        .     . nbftri .   1 : famille MED                          .
  76 c .        .     .        .   2 : type de triangle                     .
  77 c .        .     .        .   3 : numero de surface de frontiere       .
  78 c .        .     .        .   4 : famille des aretes internes apres raf.
  79 c .        .     .        . + l : appartenance a l'equivalence l       .
  80 c . famqua . e   . nbquto . famille des quadrangles                    .
  81 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  82 c .        .     . nbfqua .   1 : famille MED                          .
  83 c .        .     .        .   2 : type de quadrangle                   .
  84 c .        .     .        .   3 : numero de surface de frontiere       .
  85 c .        .     .        .   4 : famille des aretes internes apres raf.
  86 c .        .     .        .   5 : famille des triangles de conformite  .
  87 c .        .     .        .   6 : famille de sf active/inactive        .
  88 c .        .     .        . + l : appartenance a l'equivalence l       .
  89 c . lapile .  a  .   *    . tableau de travail                         .
  90 c . tabau2 .  a  . nbnoto . tableau de travail                         .
  91 c . tabau3 .  a  . nbarto . tableau de travail                         .
  92 c . taba15 .  a  . nbarto . tableau de travail                         .
  93 c . taba16 .  a  .   *    . tableau de travail                         .
  94 c . nublfa .  s  .-nbquto . numero du bloc pour chaque face            .
  95 c .        .     . :nbtrto.                                            .
  96 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  97 c .        .     .        . si 0 : on n'ecrit rien                     .
  98 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  99 c . langue . e   .    1   . langue des messages                        .
 100 c .        .     .        . 1 : francais, 2 : anglais                  .
 101 c . codret .  s  .    1   . code de retour des modules                 .
 102 c .        .     .        . 0 : pas de probleme                        .
 103 c .        .     .        . 1 : probleme                               .
 104 c .____________________________________________________________________.
 105 c
 106 c====
 107 c 0. declarations et dimensionnement
 108 c====
 109 c
 110 c 0.1. ==> generalites
 111 c
 112       implicit none
 113       save
 114 c
 115       character*6 nompro
 116       parameter ( nompro = 'UTB11C' )
 117 c
 118 #include "nblang.h"
 119 #include "coftex.h"
 120 c
 121 c 0.2. ==> communs
 122 c
 123 #include "envex1.h"
 124 #include "nbfami.h"
 125 #include "nombno.h"
 126 #include "nombar.h"
 127 #include "nombtr.h"
 128 #include "nombqu.h"
 129 c
 130 #include "dicfen.h"
 131 #include "impr02.h"
 132 c
 133 c 0.3. ==> arguments
 134 c
 135       integer nbbloc, option
 136       integer tabau4(-nbquto:*)
 137       integer hetare(nbarto), somare(2,nbarto)
 138       integer hettri(nbtrto), aretri(nbtrto,3)
 139       integer hetqua(nbquto), arequa(nbquto,4)
 140       integer povoso(0:nbnoto), voisom(*)
 141       integer posifa(0:nbarto), facare(nbfaar)
 142 c
 143       integer famare(nbarto), cfaare(nctfar,nbfare)
 144       integer famtri(nbtrto), cfatri(nctftr,nbftri)
 145       integer famqua(nbquto), cfaqua(nctfqu,nbfqua)
 146 c
 147       integer lapile(*)
 148       integer tabau2(nbnoto)
 149       integer tabau3(nbarto)
 150       integer taba15(nbarto)
 151       integer taba16(*)
 152       integer nublfa(-nbquto:*)
 153 c
 154       integer ulbila
 155       integer ulsort, langue, codret
 156 c
 157 c 0.4. ==> variables locales
 158 c
 159       integer iaux, jaux, kaux, laux, maux, ldeb, lfin
 160       integer tbiaux(1)
 161       integer laface, typfa0, typfac
 162       integer etat
 163       integer elem, lgpile, nbaret
 164       integer nbblar
 165 c
 166       integer nbmess
 167       parameter (nbmess = 10 )
 168       character*80 texte(nblang,nbmess)
 169 c
 170 c 0.5. ==> initialisations
 171 c ______________________________________________________________________
 172 c
 173 c====
 174 c 1. messages
 175 c====
 176 c
 177 #include "impr01.h"
 178 c
 179 #ifdef _DEBUG_HOMARD_
 180       write (ulsort,texte(langue,1)) 'Entree', nompro
 181       call dmflsh (iaux)
 182 #endif
 183 c
 184       texte(1,4) = '(/,3x,''. Connexite des '',a)'
 185       texte(1,5) = '(''.. Impression du bloc'',i8)'
 186 c
 187       texte(2,4) = '(/,3x,''. Connexity of '',a)'
 188       texte(2,5) = '(''.. Printing of block #'',i8)'
 189 c
 190 #include "impr03.h"
 191 c
 192       if ( nbtrac.eq.0 ) then
 193         typfa0 = 4
 194       elseif ( nbquac.eq.0 ) then
 195         typfa0 = 2
 196       else
 197         typfa0 = 8
 198       endif
 199 c
 200 #ifdef _DEBUG_HOMARD_
 201       write (ulsort,texte(langue,4)) mess14(langue,3,typfa0)
 202       write (ulsort,90002) 'option', option
 203 #endif
 204 c
 205 c 1.3. ==> Aucun bloc au depart
 206 c
 207 cgn      write (ulsort,90002) 'nbquto', nbquto
 208 cgn      write (ulsort,90002) 'nbtrto', nbtrto
 209       do 13 , iaux = -nbquto , nbtrto
 210         nublfa(iaux) = 0
 211    13 continue
 212       nublfa(0) = -1
 213 c
 214       codret = 0
 215 c
 216 c====
 217 c 2. blocs de faces
 218 c====
 219 #ifdef _DEBUG_HOMARD_
 220       write (ulsort,90002) '2. blocs de faces ; codret =', codret
 221 #endif
 222 c
 223       nbbloc = 0
 224       lgpile = 0
 225 c
 226       do 22 , laface = -nbquto , nbtrto
 227 c
 228 #ifdef _DEBUG_HOMARD_
 229         if ( laface.ne.0 ) then
 230       write (ulsort,90015) 'Debut boucle 22, avant le bloc',nbbloc+1,
 231      >', laface = ', laface, tabau4(laface)
 232       endif
 233 #endif
 234 c       On examine les faces presentes dans la liste transmise
 235 c
 236         if ( tabau4(laface).eq.1 ) then
 237 c
 238 c       On examine les faces qui ne sont pas deja dans un bloc
 239 c
 240         if ( nublfa(laface).eq.0 ) then
 241 c
 242 #ifdef _DEBUG_HOMARD_
 243       if ( laface.gt.0 ) then
 244         write (ulsort,90015) 'etat = ', hettri(laface),
 245      > ',  type =',cfatri(cotyel,famtri(laface))
 246       elseif ( laface.lt.0 ) then
 247         write (ulsort,90015) 'etat = ', hetqua(-laface),
 248      > ',  type =',cfaqua(cotyel,famqua(-laface))
 249       endif
 250 #endif
 251 c
 252         if ( option.gt.0 ) then
 253 c
 254           etat = -9999
 255           if ( laface.gt.0 ) then
 256             etat = mod( hettri(laface) , 10 )
 257 #ifdef _DEBUG_HOMARD_
 258         write (ulsort,90015) 'etat = ', etat,
 259      > ',  type =',cfatri(cotyel,famtri(laface))
 260 #endif
 261             if ( option.gt.1 ) then
 262               if ( cfatri(cotyel,famtri(laface)).eq.0 ) then
 263                 etat = -9999
 264               endif
 265             endif
 266           elseif ( laface.lt.0 ) then
 267             etat = mod( hetqua(-laface) , 100 )
 268 #ifdef _DEBUG_HOMARD_
 269         write (ulsort,90015) 'etat = ', etat,
 270      > ',  type =',cfaqua(cotyel,famqua(-laface))
 271 #endif
 272             if ( option.gt.1 ) then
 273               if ( cfaqua(cotyel,famqua(-laface)).eq.0 ) then
 274                 etat = -9999
 275               endif
 276             endif
 277           endif
 278 c
 279         else
 280 c
 281           etat = 0
 282 c
 283         endif
 284 c
 285         if ( etat.eq.0 ) then
 286 c
 287 c 2.1. ==> on commence un nouveau bloc :
 288 c 2.1.1. ==> impression des caracteristiques du bloc precedent
 289 c
 290           if ( ulbila.gt.0 .and. nbbloc.ge.1 ) then
 291 c
 292 c 2.1.1.1. ==> recherche des aretes actives de ce bloc
 293 c
 294             if ( codret.eq.0 ) then
 295 c
 296             iaux = 2
 297 #ifdef _DEBUG_HOMARD_
 298       write (ulsort,texte(langue,3)) 'UTB11E', nompro
 299 #endif
 300             call utb11e ( iaux, nbbloc, nublfa,
 301      >                    somare,
 302      >                    aretri, arequa,
 303      >                    tbiaux, tbiaux, tbiaux, tbiaux,
 304      >                      jaux,   jaux,   jaux,   jaux,
 305      >                    tabau3, tabau4,
 306      >                    ulsort, langue, codret )
 307 c
 308             endif
 309 c
 310 c 2.1.1.2. ==> recherche des blocs d'aretes actives de ce bloc
 311 c
 312             if ( codret.eq.0 ) then
 313 c
 314             iaux = 1
 315             jaux = 0
 316 #ifdef _DEBUG_HOMARD_
 317       write (ulsort,texte(langue,3)) 'UTB11D', nompro
 318 #endif
 319             call utb11d ( nbblar, iaux, tabau3,
 320      >                    hetare, somare,
 321      >                    povoso, voisom,
 322      >                    famare, cfaare,
 323      >                    taba15, tabau2,
 324      >                    taba16,
 325      >                      jaux,
 326      >                    ulsort, langue, codret )
 327 c
 328             endif
 329 c
 330 c 2.1.1.3. ==> impression veritable
 331 c
 332             if ( codret.eq.0 ) then
 333 c
 334 #ifdef _DEBUG_HOMARD_
 335       write (ulsort,texte(langue,5)) nbbloc
 336 #endif
 337 c
 338             jaux = 0
 339 #ifdef _DEBUG_HOMARD_
 340       write (ulsort,texte(langue,3)) 'UTB11F', nompro
 341 #endif
 342             call utb11f ( nbbloc, nbblar, typfa0, typfac,
 343      >                    nublfa, tabau2, tabau3, tabau4,
 344      >                    ulbila,
 345      >                    ulsort, langue, codret )
 346 c
 347             endif
 348 c
 349           endif
 350 c
 351 c 2.1.2. ==> initialisations
 352 c
 353           nbbloc = nbbloc + 1
 354           elem = laface
 355 #ifdef _DEBUG_HOMARD_
 356       write (ulsort,90015) 'debut du bloc',nbbloc,' avec elem = ', elem
 357 #endif
 358 c
 359           do 2121 , iaux = 1 , nbnoto
 360             tabau2(iaux) = 0
 361  2121     continue
 362           do 2122 , iaux = 1 , nbarto
 363             tabau3(iaux) = 0
 364  2122     continue
 365 c
 366           typfac = 0
 367 c
 368    21     continue
 369 c
 370 #ifdef _DEBUG_HOMARD_
 371       write (ulsort,90015) 'bloc ',nbbloc,' avec elem = ', elem
 372 #endif
 373 c
 374 c 2.2. ==> memorisation du bloc pour l'element courant
 375 c
 376           nublfa(elem) = nbbloc
 377 cgn          print *,'elem,nbbloc ',elem, nbbloc
 378 c
 379           if ( elem.lt.0 ) then
 380             if ( typfac.eq.0 ) then
 381               typfac = 4
 382             elseif ( typfac.ne.4 ) then
 383               typfac = 8
 384             endif
 385           else
 386             if ( typfac.eq.0 ) then
 387               typfac = 2
 388             elseif ( typfac.ne.2 ) then
 389               typfac = 8
 390             endif
 391           endif
 392 c
 393 c 2.3. ==> mise des voisins dans la pile
 394 c
 395           if ( elem.gt.0 ) then
 396             nbaret = 3
 397           else
 398             nbaret = 4
 399           endif
 400 c
 401           do 222 , iaux = 1 , nbaret
 402 c
 403 c 2.3.1. ==> reperage des voisins de elem par sa iaux-ieme arete
 404 c
 405             if ( elem.gt.0 ) then
 406               jaux = aretri(elem,iaux)
 407             else
 408               jaux = arequa(-elem,iaux)
 409             endif
 410             tabau3(jaux) = tabau3(jaux) + 1
 411             kaux = somare(1,jaux)
 412             tabau2(kaux) = tabau2(kaux) + 1
 413             kaux = somare(2,jaux)
 414             tabau2(kaux) = tabau2(kaux) + 1
 415             ldeb = posifa(jaux-1)+1
 416             lfin = posifa(jaux)
 417 c
 418 c 2.3.2. ==> examen des voisins qui ne sont pas deja dans un bloc
 419 c            et qui font partie de la liste
 420 c
 421             do 2221 , laux = ldeb, lfin
 422 c
 423               kaux = facare(laux)
 424               if ( nublfa(kaux).eq.0 ) then
 425 c
 426                 if ( tabau4(kaux).eq.1 ) then
 427                   if ( option.gt.0 ) then
 428                     etat = -2220
 429                     if ( kaux.gt.0 ) then
 430                       etat = mod( hettri(kaux) , 10 )
 431 cgn        write (ulsort,*) kaux,' : etat = ', etat,
 432 cgn     > ',  type =',cfatri(cotyel,famtri(kaux))
 433                       if ( option.gt.1 ) then
 434                         if ( cfatri(cotyel,famtri(kaux)).eq.0 ) then
 435                           etat = -2221
 436                         endif
 437                       endif
 438                     else
 439                       etat = mod( hetqua(-kaux) , 100 )
 440 cgn        write (ulsort,*) kaux,' : etat = ', etat,
 441 cgn     > ',  type =',cfaqua(cotyel,famqua(-kaux))
 442                       if ( option.gt.1 ) then
 443                         if ( cfaqua(cotyel,famqua(-kaux)).eq.0 ) then
 444                           etat = -2222
 445                         endif
 446                       endif
 447                     endif
 448                   else
 449                     etat = 0
 450                   endif
 451 cgn                print *,'==> etat ',etat
 452                   if ( etat.eq.0 ) then
 453                     do 2222 , maux = 1 , lgpile
 454                       if ( lapile(maux).eq.kaux ) then
 455                         goto 2221
 456                       endif
 457  2222               continue
 458 cgn        write (ulsort,*) '==> ajout de', kaux
 459                     lgpile = lgpile + 1
 460                     lapile(lgpile) = kaux
 461 #ifdef _DEBUG_HOMARD_
 462 cgn      write (ulsort,1789) (lapile(maux), maux = 1 , lgpile)
 463 cgn 1789 format(10i5)
 464 #endif
 465                   endif
 466                 endif
 467 c
 468               endif
 469 c
 470  2221       continue
 471 c
 472   222     continue
 473 c
 474 c 2.4. ==> on passe a l'element suivant de la pile
 475 c
 476           if ( lgpile.gt.0 ) then
 477 c
 478             elem = lapile(lgpile)
 479             lgpile = lgpile - 1
 480             goto 21
 481 c
 482           endif
 483 #ifdef _DEBUG_HOMARD_
 484       write (ulsort,90002) 'fin du bloc', nbbloc
 485       write (ulsort,*) 'tabau2 (noeuds)'
 486       write (ulsort,91040) (tabau2(iaux), iaux=1,min(20,nbnoto))
 487       write (ulsort,*) 'tabau3 (aretes)'
 488       write (ulsort,91040) (tabau3(iaux), iaux=1,min(20,nbarto))
 489 c      write (ulsort,91040) (tabau3(iaux), iaux=1,min(20000,nbarto))
 490 #endif
 491 c
 492         endif
 493 c
 494 c 2.5. ==> on continue la liste des faces en prevision d'un eventuel
 495 c          nouveau bloc
 496 c
 497         endif
 498 c
 499         endif
 500 c
 501    22 continue
 502 c
 503 c====
 504 c 3. impression du dernier bloc
 505 c====
 506 #ifdef _DEBUG_HOMARD_
 507       write(ulsort,90002) '3. impression dernier bloc ; codret', codret
 508 #endif
 509 c
 510       if ( codret.eq.0 ) then
 511 c
 512       if ( ulbila.gt.0 .and. nbbloc.gt.0 ) then
 513 c
 514 c 3.1. ==> recherche des aretes actives de ce bloc
 515 c
 516         if ( codret.eq.0 ) then
 517 c
 518         iaux = 2
 519 #ifdef _DEBUG_HOMARD_
 520       write (ulsort,texte(langue,3)) 'UTB11E', nompro
 521 #endif
 522         call utb11e ( iaux, nbbloc, nublfa,
 523      >                somare,
 524      >                aretri, arequa,
 525      >                tbiaux, tbiaux, tbiaux, tbiaux,
 526      >                  jaux,   jaux,   jaux,   jaux,
 527      >                tabau3, tabau4,
 528      >                ulsort, langue, codret )
 529 c
 530         endif
 531 c
 532 c 3.2. ==> recherche des blocs d'aretes actives de ce bloc
 533 c
 534         if ( codret.eq.0 ) then
 535 c
 536         iaux = 1
 537         jaux = 0
 538 #ifdef _DEBUG_HOMARD_
 539       write (ulsort,texte(langue,3)) 'UTB11D', nompro
 540 #endif
 541         call utb11d ( nbblar, iaux, tabau3,
 542      >                hetare, somare,
 543      >                povoso, voisom,
 544      >                famare, cfaare,
 545      >                taba15, tabau2,
 546      >                taba16,
 547      >                  jaux,
 548      >                ulsort, langue, codret )
 549 c
 550         endif
 551 c
 552 c 3.3. ==> impression veritable
 553 c
 554         if ( codret.eq.0 ) then
 555 c
 556 #ifdef _DEBUG_HOMARD_
 557       write (ulsort,texte(langue,5)) nbbloc
 558 #endif
 559 c
 560         if ( nbbloc.eq.1 ) then
 561           iaux = -nbbloc
 562         else
 563           iaux =  nbbloc
 564         endif
 565 #ifdef _DEBUG_HOMARD_
 566       write (ulsort,texte(langue,3)) 'UTB11F', nompro
 567 #endif
 568         call utb11f ( iaux, nbblar, typfa0, typfac,
 569      >                nublfa, tabau2, tabau3, tabau4,
 570      >                ulbila,
 571      >                ulsort, langue, codret )
 572 c
 573         write (ulbila,3000)
 574  3000   format(5x,58('*'))
 575 c
 576         endif
 577 c
 578       endif
 579 c
 580       endif
 581 c
 582 c====
 583 c 4. la fin
 584 c====
 585 c
 586       if ( codret.ne.0 ) then
 587 c
 588 #include "envex2.h"
 589 c
 590       write (ulsort,texte(langue,1)) 'Sortie', nompro
 591       write (ulsort,texte(langue,2)) codret
 592 c
 593       endif
 594 c
 595 #ifdef _DEBUG_HOMARD_
 596       write (ulsort,texte(langue,1)) 'Sortie', nompro
 597       call dmflsh (iaux)
 598 #endif
 599 c
 600       end