src/tool/Utilitaire/utb11a.F

   1       subroutine utb11a ( hetare, somare,
   2      >                    hettri, aretri,
   3      >                    voltri, pypetr,
   4      >                    hetqua, arequa,
   5      >                    volqua, pypequ,
   6      >                    hettet, tritet,
   7      >                    hethex, quahex,
   8      >                    hetpyr, facpyr,
   9      >                    hetpen, facpen,
  10      >                    povoso, voisom,
  11      >                    posifa, facare,
  12      >                    famare, cfaare,
  13      >                    famtri, cfatri,
  14      >                    famqua, cfaqua,
  15      >                    famtet, cfatet,
  16      >                    famhex, cfahex,
  17      >                    fampyr, cfapyr,
  18      >                    fampen, cfapen,
  19      >                    tabau1, tabau2, tabau3, tabau4,
  20      >                    taba11, taba12, taba13, taba14,
  21      >                    taba15, taba16,
  22      >                    nublen,
  23      >                    ulbila,
  24      >                    ulsort, langue, codret )
  25 c ______________________________________________________________________
  26 c
  27 c                             H O M A R D
  28 c
  29 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  30 c
  31 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  32 c aupres des huissiers de justice Simart et Lavoir a Clamart
  33 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  34 c aupres des huissiers de justice
  35 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  36 c
  37 c    HOMARD est une marque deposee d'Electricite de France
  38 c
  39 c Copyright EDF 1996
  40 c Copyright EDF 1998
  41 c Copyright EDF 2002
  42 c Copyright EDF 2020
  43 c ______________________________________________________________________
  44 c
  45 c    UTilitaire - Bilan sur le maillage - option 11
  46 c    --           -                              --
  47 c ______________________________________________________________________
  48 c
  49 c    analyse de la connexite du maillage de calcul
  50 c    remarque : pour du raffinement non-conforme, chaque niveau est
  51 c               un bloc
  52 c ______________________________________________________________________
  53 c .        .     .        .                                            .
  54 c .  nom   . e/s . taille .           description                      .
  55 c .____________________________________________________________________.
  56 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  57 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  58 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  59 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  60 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  61 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  62 c .        .     .        .   0 : pas de voisin                        .
  63 c .        .     .        . j>0 : tetraedre j                          .
  64 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  65 c . pypetr . e   .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
  66 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  67 c .        .     .        . pypetr(2,j) = numero du pentaedre voisin   .
  68 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  69 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  70 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  71 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  72 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  73 c .        .     .        .   0 : pas de voisin                        .
  74 c .        .     .        . j>0 : hexaedre j                           .
  75 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  76 c . pypequ . e   .2*lgpype. pypequ(1,j) = numero de la pyramide voisine.
  77 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  78 c .        .     .        . pypequ(2,j) = numero du pentaedre voisin   .
  79 c .        .     .        . du quadrangle k tel que volqua(1/2,k) = -j .
  80 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  81 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  82 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  83 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  84 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  85 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  86 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  87 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  88 c . povoso . e   .0:nbnoto. pointeur des voisins par noeud             .
  89 c . voisom . e   . nvosom . aretes voisines de chaque noeud            .
  90 c . posifa . e   .0:nbarto. pointeur sur tableau facare                .
  91 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  92 c . famare . e   . nbarto . famille des aretes                         .
  93 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  94 c .        .     . nbfare .   1 : famille MED                          .
  95 c .        .     .        .   2 : type de segment                      .
  96 c .        .     .        .   3 : orientation                          .
  97 c .        .     .        .   4 : famille d'orientation inverse        .
  98 c .        .     .        .   5 : numero de ligne de frontiere         .
  99 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
 100 c .        .     .        . <= 0 si non concernee                      .
 101 c .        .     .        .   6 : famille frontiere active/inactive    .
 102 c .        .     .        .   7 : numero de surface de frontiere       .
 103 c .        .     .        . + l : appartenance a l'equivalence l       .
 104 c . famtri . e   . nbtrto . famille des triangles                      .
 105 c . cfatri . e   . nctftr*. codes des familles des triangles           .
 106 c .        .     . nbftri .   1 : famille MED                          .
 107 c .        .     .        .   2 : type de triangle                     .
 108 c .        .     .        .   3 : numero de surface de frontiere       .
 109 c .        .     .        .   4 : famille des aretes internes apres raf.
 110 c .        .     .        . + l : appartenance a l'equivalence l       .
 111 c . famqua . e   . nbquto . famille des quadrangles                    .
 112 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
 113 c .        .     . nbfqua .   1 : famille MED                          .
 114 c .        .     .        .   2 : type de quadrangle                   .
 115 c .        .     .        .   3 : numero de surface de frontiere       .
 116 c .        .     .        .   4 : famille des aretes internes apres raf.
 117 c .        .     .        .   5 : famille des triangles de conformite  .
 118 c .        .     .        .   6 : famille de sf active/inactive        .
 119 c .        .     .        . + l : appartenance a l'equivalence l       .
 120 c . famtet . e   . nbteto . famille des tetraedres                     .
 121 c . cfatet .     . nctfte*. codes des familles des tetraedres          .
 122 c .        .     . nbftet .   1 : famille MED                          .
 123 c .        .     .        .   2 : type de tetraedres                   .
 124 c . famhex . e   . nbheto . famille des hexaedres                      .
 125 c . cfahex .     . nctfhe*. codes des familles des hexaedres           .
 126 c .        .     . nbfhex .   1 : famille MED                          .
 127 c .        .     .        .   2 : type d'hexaedres                     .
 128 c .        .     .        .   3 : famille des tetraedres de conformite .
 129 c .        .     .        .   4 : famille des pyramides de conformite  .
 130 c . fampyr . e   . nbpyto . famille des pyramides                      .
 131 c . cfapyr .     . nctfpy*. codes des familles des pyramides           .
 132 c .        .     . nbfpyr .   1 : famille MED                          .
 133 c .        .     .        .   2 : type de pyramides                    .
 134 c . fampen . e   . nbpeto . famille des pentaedres                     .
 135 c . cfapen .     . nctfpe*. codes des familles des pentaedres          .
 136 c .        .     . nbfpen .   1 : famille MED                          .
 137 c .        .     .        .   2 : type de pentaedres                   .
 138 c .        .     .        .   3 : famille des tetraedres de conformite .
 139 c .        .     .        .   4 : famille des pyramides de conformite  .
 140 c . tabau1 .  a  .   *    . tableau de travail                         .
 141 c . tabau2 .  a  .   *    . tableau de travail                         .
 142 c . tabau3 .  a  .   *    . tableau de travail                         .
 143 c . tabau4 .  a  .-nbquto . tableau de travail                         .
 144 c .        .     . :nbtrto.                                            .
 145 c . taba11 .  a  .    *   . tableau de travail                         .
 146 c . taba12 .  a  . nbnoto . tableau de travail                         .
 147 c . taba13 .  a  . nbarto . tableau de travail                         .
 148 c . taba14 .  a  .    *   . tableau de travail                         .
 149 c . taba15 .  a  . nbarto . tableau de travail                         .
 150 c . taba16 .  a  .   *    . tableau de travail                         .
 151 c . nublen .  s  .   *    . numero de blocs par entite                 .
 152 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
 153 c . ulsort . e   .   1    . unite logique de la sortie generale        .
 154 c . langue . e   .    1   . langue des messages                        .
 155 c .        .     .        . 1 : francais, 2 : anglais                  .
 156 c . codret .  s  .    1   . code de retour des modules                 .
 157 c .        .     .        . 0 : pas de probleme                        .
 158 c .        .     .        . 1 : probleme                               .
 159 c .____________________________________________________________________.
 160 c
 161 c====
 162 c 0. declarations et dimensionnement
 163 c====
 164 c
 165 c 0.1. ==> generalites
 166 c
 167       implicit none
 168       save
 169 c
 170       character*6 nompro
 171       parameter ( nompro = 'UTB11A' )
 172 c
 173 #include "nblang.h"
 174 c
 175 c 0.2. ==> communs
 176 c
 177 #include "envex1.h"
 178 c
 179 #include "nbfami.h"
 180 #include "nombno.h"
 181 #include "nombar.h"
 182 #include "nombtr.h"
 183 #include "nombqu.h"
 184 #include "nombte.h"
 185 #include "nombhe.h"
 186 #include "nombpy.h"
 187 #include "nombpe.h"
 188 c
 189 #include "dicfen.h"
 190 #include "impr02.h"
 191 c
 192 c 0.3. ==> arguments
 193 c
 194       integer hetare(nbarto), somare(2,nbarto)
 195       integer hettri(nbtrto), aretri(nbtrto,3)
 196       integer voltri(2,nbtrto), pypetr(2,*)
 197       integer hetqua(nbquto), arequa(nbquto,4)
 198       integer volqua(2,nbquto), pypequ(2,*)
 199       integer hettet(nbteto), tritet(nbtecf,4)
 200       integer hethex(nbheto), quahex(nbhecf,6)
 201       integer hetpyr(nbpyto), facpyr(nbpycf,5)
 202       integer hetpen(nbpeto), facpen(nbpecf,5)
 203       integer povoso(0:nbnoto), voisom(*)
 204       integer posifa(0:nbarto), facare(nbfaar)
 205 c
 206       integer famare(nbarto), cfaare(nctfar,nbfare)
 207       integer famtri(nbtrto), cfatri(nctftr,nbftri)
 208       integer famqua(nbquto), cfaqua(nctfqu,nbfqua)
 209       integer famtet(nbteto), cfatet(nctfte,nbftet)
 210       integer famhex(nbheto), cfahex(nctfhe,nbfhex)
 211       integer fampyr(nbpyto), cfapyr(nctfpy,nbfpyr)
 212       integer fampen(nbpeto), cfapen(nctfpe,nbfpen)
 213 c
 214       integer tabau1(*)
 215       integer tabau2(nbnoto)
 216       integer tabau3(nbarto)
 217       integer tabau4(-nbquto:*)
 218       integer taba11(*)
 219       integer taba12(nbnoto)
 220       integer taba13(nbarto)
 221       integer taba14(*)
 222       integer taba15(nbarto)
 223       integer taba16(*)
 224       integer nublen(-nbquto:*)
 225 c
 226       integer ulbila
 227       integer ulsort, langue, codret
 228 c
 229 c 0.4. ==> variables locales
 230 c
 231       integer iaux
 232       integer nbblar, nbblfa, nbblvo
 233 c
 234       integer nbmess
 235       parameter (nbmess = 10 )
 236       character*80 texte(nblang,nbmess)
 237 c
 238 c 0.5. ==> initialisations
 239 c ______________________________________________________________________
 240 c
 241 c====
 242 c 1. messages
 243 c====
 244 c
 245 #include "impr01.h"
 246 c
 247 #ifdef _DEBUG_HOMARD_
 248       write (ulsort,texte(langue,1)) 'Entree', nompro
 249       call dmflsh (iaux)
 250 #endif
 251 c
 252       texte(1,4) =
 253      > '(//,3x,''CONNEXITE DES ENTITES DU CALCUL'',/,3x,31(''=''),/)'
 254       texte(1,5) =
 255      >'(5x,''*'',19x,''Blocs de '',a,14x,''*'')'
 256 c
 257       texte(2,4) =
 258      > '(//,3x,''CONNEXITY OF CALCULATION ENTITIES'',/,3x,33(''=''),/)'
 259       texte(2,5) =
 260      >'(5x,''*'',19x,''Blocks of '',a,13x,''*'')'
 261 c
 262       write (ulbila,texte(langue,4))
 263 c
 264 #ifdef _DEBUG_HOMARD_
 265 10001 format(4x,60('-'))
 266 #endif
 267 c
 268 #include "impr03.h"
 269 c
 270       codret = 0
 271 c
 272 c====
 273 c 2. blocs de volumes
 274 c    Remarque : impossible si des volumes sont decrits par leurs aretes
 275 c====
 276 c
 277       if ( codret.eq.0 ) then
 278 c
 279       if ( nbteca.eq.0 .and. nbheca.eq.0 .and.
 280      >     nbpyca.eq.0 .and. nbpeca.eq.0 ) then
 281 c
 282 c
 283       if ( nbteac.gt.0 .or. nbheac.gt.0 .or.
 284      >     nbpyac.gt.0 .or. nbpeac.gt.0 ) then
 285 c
 286 #ifdef _DEBUG_HOMARD_
 287       write (ulsort,texte(langue,3)) 'UTB11B', nompro
 288 #endif
 289         call utb11b ( nbblvo,
 290      >                hetare, somare,
 291      >                hettri, aretri,
 292      >                hetqua, arequa,
 293      >                hettet, tritet,
 294      >                hethex, quahex,
 295      >                hetpyr, facpyr,
 296      >                hetpen, facpen,
 297      >                povoso, voisom,
 298      >                posifa, facare,
 299      >                voltri, pypetr,
 300      >                volqua, pypequ,
 301      >                famare, cfaare,
 302      >                famtri, cfatri,
 303      >                famqua, cfaqua,
 304      >                famtet, cfatet,
 305      >                famhex, cfahex,
 306      >                fampyr, cfapyr,
 307      >                fampen, cfapen,
 308      >                tabau1, tabau2, tabau3, tabau4,
 309      >                taba11, taba12, taba13, taba14,
 310      >                taba15, taba16,
 311      >                nublen,
 312      >                ulbila,
 313      >                ulsort, langue, codret )
 314 c
 315 #ifdef _DEBUG_HOMARD_
 316       write(ulsort,90002) 'Fin etape 2 avec codret', codret
 317       write(ulsort,texte(langue,5)) mess14(langue,3,3)
 318       write(ulsort,91040) (iaux,
 319      > iaux=1,min(20,nbteto+nbheto+nbpyto-nbquto))
 320       write(ulsort,10001)
 321       write(ulsort,91040) (nublen(iaux),
 322      > iaux=-nbquto,nbteto+nbheto+nbpyto-nbquto-1)
 323 #endif
 324 c
 325       endif
 326 c
 327       endif
 328 c
 329       endif
 330 c
 331 c====
 332 c 3. blocs de faces
 333 c====
 334 #ifdef _DEBUG_HOMARD_
 335       write (ulsort,90002) '3. bloc de faces ; codret', codret
 336 #endif
 337 c
 338       if ( codret.eq.0 ) then
 339 c
 340       if ( nbtrac.gt.0 .or. nbquac.gt.0 ) then
 341 c
 342 c       on examine toutes les faces actives du calcul
 343 c
 344         do 31 , iaux = -nbquto, nbtrto
 345           tabau4(iaux) = 1
 346    31   continue
 347         tabau4(0) = 0
 348         iaux = 2
 349 c
 350 #ifdef _DEBUG_HOMARD_
 351       write (ulsort,texte(langue,3)) 'UTB11C', nompro
 352 #endif
 353         call utb11c ( nbblfa, iaux, tabau4,
 354      >                hetare, somare,
 355      >                hettri, aretri,
 356      >                hetqua, arequa,
 357      >                povoso, voisom,
 358      >                posifa, facare,
 359      >                famare, cfaare,
 360      >                famtri, cfatri,
 361      >                famqua, cfaqua,
 362      >                tabau1, tabau2, tabau3,
 363      >                taba15, taba16,
 364      >                nublen,
 365      >                ulbila,
 366      >                ulsort, langue, codret )
 367 c
 368 #ifdef _DEBUG_HOMARD_
 369       write (ulsort,90002) 'Fin etape 3 avec codret', codret
 370       if ( nbtrac.gt.0  ) then
 371         write(ulsort,texte(langue,5)) mess14(langue,3,2)
 372         write(ulsort,91040) (iaux,iaux=1,min(20,nbtrto))
 373         write(ulsort,10001)
 374         write(ulsort,91040)
 375      >(nublen(iaux),iaux=-nbquto+1,-nbquto+min(100,nbtrto))
 376       endif
 377       if ( nbquac.gt.0  ) then
 378         write(ulsort,texte(langue,5)) mess14(langue,3,4)
 379         write(ulsort,91040) (iaux,iaux=1,min(20,nbquto))
 380         write(ulsort,10001)
 381         write(ulsort,91040)
 382      >(nublen(iaux),iaux=-nbquto,-nbquto+min(100,nbquto)-1)
 383       endif
 384 #endif
 385 c
 386       endif
 387 c
 388       endif
 389 c
 390 c====
 391 c 4. blocs d'aretes
 392 c====
 393 #ifdef _DEBUG_HOMARD_
 394       write (ulsort,90002) '4. bloc d aretes ; codret', codret
 395 #endif
 396 c
 397       if ( codret.eq.0 ) then
 398 c
 399 c       on examine toutes les aretes actives du calcul
 400 c
 401         do 41 , iaux = 1, nbarto
 402           tabau3(iaux) = 1
 403    41   continue
 404         iaux = 2
 405 c
 406 #ifdef _DEBUG_HOMARD_
 407       write (ulsort,texte(langue,3)) 'UTB11D', nompro
 408 #endif
 409         call utb11d ( nbblar, iaux, tabau3,
 410      >                hetare, somare,
 411      >                povoso, voisom,
 412      >                famare, cfaare,
 413      >                tabau1, tabau2,
 414      >                nublen,
 415      >                ulbila,
 416      >                ulsort, langue, codret )
 417 c
 418 #ifdef _DEBUG_HOMARD_
 419       write (ulsort,90002) 'Fin etape 4 avec codret', codret
 420       write(ulsort,texte(langue,5)) mess14(langue,3,1)
 421       write(ulsort,91040) (iaux,iaux=1,min(20,nbarto))
 422       write(ulsort,10001)
 423       write(ulsort,91040)
 424      >(nublen(iaux),iaux=-nbquto,-nbquto+min(100,nbarto)-1)
 425 #endif
 426 c
 427       endif
 428 c
 429 c====
 430 c 5. la fin
 431 c====
 432 c
 433       if ( codret.ne.0 ) then
 434 c
 435 #include "envex2.h"
 436 c
 437       write (ulsort,texte(langue,1)) 'Sortie', nompro
 438       write (ulsort,texte(langue,2)) codret
 439 c
 440       endif
 441 c
 442 #ifdef _DEBUG_HOMARD_
 443       write (ulsort,texte(langue,1)) 'Sortie', nompro
 444       call dmflsh (iaux)
 445 #endif
 446 c
 447       end