src/tool/Utilitaire/utb07a.F

   1       subroutine utb07a ( hetare,
   2      >                    hettri, nivtri, pertri,
   3      >                    voltri,
   4      >                    hetqua, nivqua,
   5      >                    volqua,
   6      >                    hettet, tritet, pertet, pthepe,
   7      >                    hethex, quahex, perhex,
   8      >                    hetpyr, facpyr, perpyr, pphepe,
   9      >                    hetpen, facpen, perpen,
  10      >                    posifa, facare,
  11      >                    famnoe, cfanoe,
  12      >                    fammpo, cfampo,
  13      >                    famare, cfaare,
  14      >                    famtri, cfatri,
  15      >                    famqua, cfaqua,
  16      >                    famtet, cfatet,
  17      >                    famhex, cfahex,
  18      >                    fampyr, cfapyr,
  19      >                    fampen, cfapen,
  20      >                    tabaui,
  21      >                    ulbila,
  22      >                    ulsort, langue, codret )
  23 c ______________________________________________________________________
  24 c
  25 c                             H O M A R D
  26 c
  27 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  28 c
  29 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  30 c aupres des huissiers de justice Simart et Lavoir a Clamart
  31 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  32 c aupres des huissiers de justice
  33 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  34 c
  35 c    HOMARD est une marque deposee d'Electricite de France
  36 c
  37 c Copyright EDF 1996
  38 c Copyright EDF 1998
  39 c Copyright EDF 2002
  40 c Copyright EDF 2020
  41 c ______________________________________________________________________
  42 c
  43 c    UTilitaire - Bilan sur le maillage - option 07
  44 c    --           -                              --
  45 c ______________________________________________________________________
  46 c
  47 c    Nombre de mailles du calcul qui sont actives.
  48 c ______________________________________________________________________
  49 c .        .     .        .                                            .
  50 c .  nom   . e/s . taille .           description                      .
  51 c .____________________________________________________________________.
  52 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  53 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  54 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  55 c .        .     .        .   0 : pas de voisin                        .
  56 c .        .     .        . j>0 : tetraedre j                          .
  57 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  58 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  59 c . nivtri . e   . nbtrto . niveau des triangles                       .
  60 c . pertri . e   . nbtrto . pere des triangles                         .
  61 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  62 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  63 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  64 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  65 c .        .     .        .   0 : pas de voisin                        .
  66 c .        .     .        . j>0 : hexaedre j                           .
  67 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  68 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  69 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  70 c . pertet . e   . nbteto . pere des tetraedres                        .
  71 c .        .     .        . si pertet(i) > 0 : numero du tetraedre     .
  72 c .        .     .        . si pertet(i) < 0 : -numero dans pthepe     .
  73 c . pthepe . e   .    *   . si i <= nbheco : numero de l'hexaedre      .
  74 c .        .     .        . si non : numero du pentaedre               .
  75 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  76 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  77 c . perhex . e   . nbheto . pere des hexaedres                         .
  78 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  79 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  80 c . perpyr . e   . nbpyto . pere des pyramides                         .
  81 c .        .     .        . si perpyr(i) > 0 : numero de la pyramide   .
  82 c .        .     .        . si perpyr(i) < 0 : -numero dans pphepe     .
  83 c . pphepe . e   .    *   . si i <= nbheco : numero de l'hexaedre      .
  84 c .        .     .        . si non : numero du pentaedre               .
  85 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  86 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  87 c . perpen . e   . nbpeto . pere des pentaedres                        .
  88 c . posifa . e   .0:nbarto. pointeur sur tableau facare                .
  89 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  90 c . cfanoe . e   . nctfno*. codes des familles des noeuds              .
  91 c .        .     . nbnoto .   1 : famille MED                          .
  92 c .        .     .        . + l : appartenance a l'equivalence l       .
  93 c . famnoe . e   . nbnoto . famille des aretes                         .
  94 c . cfampo . e   . nctfmp*. codes des familles des mailles-points      .
  95 c .        .     . nbfmpo .   1 : famille MED                          .
  96 c .        .     .        .   2 : type de maille-point                 .
  97 c .        .     .        .   3 : famille des sommets                  .
  98 c .        .     .        . + l : appartenance a l'equivalence l       .
  99 c . fammpo . e   . nbmpto . famille des mailles-points                 .
 100 c . cfaare . e   . nctfar*. codes des familles des aretes              .
 101 c .        .     . nbfare .   1 : famille MED                          .
 102 c .        .     .        .   2 : type de segment                      .
 103 c .        .     .        .   3 : orientation                          .
 104 c .        .     .        .   4 : famille d'orientation inverse        .
 105 c .        .     .        .   5 : numero de ligne de frontiere         .
 106 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
 107 c .        .     .        . <= 0 si non concernee                      .
 108 c .        .     .        .   6 : famille frontiere active/inactive    .
 109 c .        .     .        .   7 : numero de surface de frontiere       .
 110 c .        .     .        . + l : appartenance a l'equivalence l       .
 111 c . famtri . e   . nbtrto . famille des triangles                      .
 112 c . cfatri . e   . nctftr*. codes des familles des triangles           .
 113 c .        .     . nbftri .   1 : famille MED                          .
 114 c .        .     .        .   2 : type de triangle                     .
 115 c .        .     .        .   3 : numero de surface de frontiere       .
 116 c .        .     .        .   4 : famille des aretes internes apres raf.
 117 c .        .     .        . + l : appartenance a l'equivalence l       .
 118 c . famqua . e   . nbquto . famille des quadrangles                    .
 119 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
 120 c .        .     . nbfqua .   1 : famille MED                          .
 121 c .        .     .        .   2 : type de quadrangle                   .
 122 c .        .     .        .   3 : numero de surface de frontiere       .
 123 c .        .     .        .   4 : famille des aretes internes apres raf.
 124 c .        .     .        .   5 : famille des triangles de conformite  .
 125 c .        .     .        .   6 : famille de sf active/inactive        .
 126 c .        .     .        . + l : appartenance a l'equivalence l       .
 127 c . famtet . e   . nbteto . famille des tetraedres                     .
 128 c . cfatet .     . nctfte. codes des familles des tetraedres          .
 129 c .        .     . nbftet .   1 : famille MED                          .
 130 c .        .     .        .   2 : type de tetraedres                   .
 131 c .        .     .        . + l : appartenance a l'equivalence l       .
 132 c . famhex . e   . nbheto . famille des hexaedres                      .
 133 c . cfahex .     . nctfhe. codes des familles des hexaedres            .
 134 c .        .     . nbfhex .   1 : famille MED                          .
 135 c .        .     .        .   2 : type d'hexaedres                     .
 136 c .        .     .        .   3 : famille des tetraedres de conformite .
 137 c .        .     .        .   4 : famille des pyramides de conformite  .
 138 c . fampyr . e   . nbpyto . famille des pyramides                      .
 139 c . cfapyr .     . nctfpy. codes des familles des pyramides            .
 140 c .        .     . nbfpyr .   1 : famille MED                          .
 141 c .        .     .        .   2 : type de pyramides                    .
 142 c . fampen . e   . nbpeto . famille des pentaedres                     .
 143 c . cfapen .     . nctfpe. codes des familles des pentaedres           .
 144 c .        .     . nbfpen .   1 : famille MED                          .
 145 c .        .     .        .   2 : type de pentaedres                   .
 146 c .        .     .        .   3 : famille des tetraedres de conformite .
 147 c .        .     .        .   4 : famille des pyramides de conformite  .
 148 c . tabaui .  a  .-nivsu-1. tableau de travail                         .
 149 c .        .     .:nivsu+1.                                            .
 150 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
 151 c . ulsort . e   .   1    . unite logique de la sortie generale        .
 152 c . langue . e   .    1   . langue des messages                        .
 153 c .        .     .        . 1 : francais, 2 : anglais                  .
 154 c . codret .  s  .    1   . code de retour des modules                 .
 155 c .        .     .        . 0 : pas de probleme                        .
 156 c .        .     .        . 1 : probleme                               .
 157 c .____________________________________________________________________.
 158 c
 159 c====
 160 c 0. declarations et dimensionnement
 161 c====
 162 c
 163 c 0.1. ==> generalites
 164 c
 165       implicit none
 166       save
 167 c
 168       character*6 nompro
 169       parameter ( nompro = 'UTB07A' )
 170 c
 171 #include "nblang.h"
 172 #include "coftex.h"
 173 c
 174 c 0.2. ==> communs
 175 c
 176 #include "envex1.h"
 177 c
 178 #include "nbfami.h"
 179 #include "nombno.h"
 180 #include "nombmp.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 #include "envada.h"
 189 #include "envca1.h"
 190 c
 191 #include "dicfen.h"
 192 #include "impr02.h"
 193 c
 194 c 0.3. ==> arguments
 195 c
 196       integer hetare(nbarto)
 197       integer hettri(nbtrto), nivtri(nbtrto), pertri(nbtrto)
 198       integer voltri(2,nbtrto)
 199       integer hetqua(nbquto), nivqua(nbquto)
 200       integer volqua(2,nbquto)
 201       integer posifa(0:nbarto), facare(nbfaar)
 202       integer hettet(nbteto), tritet(nbtecf,4)
 203       integer pertet(nbteto), pthepe(*)
 204       integer hethex(nbheto), quahex(nbhecf,6)
 205       integer perhex(nbheto)
 206       integer hetpyr(nbpyto), facpyr(nbpycf,5)
 207       integer perpyr(nbpyto), pphepe(*)
 208       integer hetpen(nbpeto), facpen(nbpecf,5)
 209       integer perpen(nbpeto)
 210 c
 211       integer famnoe(nbnoto), cfanoe(nctfno,nbfnoe)
 212       integer fammpo(nbmpto), cfampo(nctfmp,nbfmpo)
 213       integer famare(nbarto), cfaare(nctfar,nbfare)
 214       integer famtri(nbtrto), cfatri(nctftr,nbftri)
 215       integer famqua(nbquto), cfaqua(nctfqu,nbfqua)
 216       integer famtet(nbteto), cfatet(nctfte,nbftet)
 217       integer famhex(nbheto), cfahex(nctfhe,nbfhex)
 218       integer fampyr(nbpyto), cfapyr(nctfpy,nbfpyr)
 219       integer fampen(nbpeto), cfapen(nctfpe,nbfpen)
 220 c
 221       integer tabaui(-nivsup-1:nivsup+1)
 222 c
 223       integer ulbila
 224       integer ulsort, langue, codret
 225 c
 226 c 0.4. ==> variables locales
 227 c
 228       integer iaux, jaux, ideb, ifin
 229       integer lenoeu, lamapo, larete, letria, lequad, letetr
 230       integer lehexa, lapyra, lepent
 231       integer etat
 232       integer nbmapo
 233       integer nbaret, nbarbt, nbarit
 234       integer nbfabt, nbfavt
 235       integer nbvolu
 236       integer pos, fac1, fac2, vois1, vois2
 237       integer nbeqno, nbeqmp, nbeqar, nbeqtr, nbeqqu
 238 c
 239       double precision niveau
 240 c
 241       logical arbord
 242 c
 243       integer nbmess
 244       parameter (nbmess = 10 )
 245       character*80 texte(nblang,nbmess)
 246       character*54 mess54(nblang,nbmess)
 247       character*43 saux43
 248       character*43 mess43(nblang,100)
 249 c
 250 c 0.5. ==> initialisations
 251 c ______________________________________________________________________
 252 c
 253 c====
 254 c 1. messages
 255 c====
 256 c
 257 #include "impr01.h"
 258 c
 259 #ifdef _DEBUG_HOMARD_
 260       write (ulsort,texte(langue,1)) 'Entree', nompro
 261       call dmflsh (iaux)
 262 #endif
 263 c
 264       texte(1,4) =
 265      > '(//,3x,''NOMBRE D''''ENTITES DU CALCUL'',/,3x,26(''=''),/)'
 266 c
 267       texte(2,4) =
 268      > '(//,3x,''NUMBER OF CALCULATION ENTITIES'',/,3x,30(''=''),/)'
 269 cgn      ulbila = ulsort
 270 c
 271       write (ulbila,texte(langue,4))
 272 c
 273       mess54(1,1) =
 274      > '   Le maillage presente des homologues.               '
 275 c
 276       mess43(1,1) = 'Nombre total                               '
 277       mess43(1,3) = '. dont sommets d''aretes                    '
 278       mess43(1,4) = '. dont milieux d''aretes                    '
 279       mess43(1,5) = '. dont noeuds internes aux mailles         '
 280       mess43(1,6) = '. dont noeuds isoles                       '
 281       mess43(1,7) = '. dont noeuds uniquement mailles ignorees  '
 282       mess43(1,8) = '. dont noeuds uniquement mailles-points    '
 283 c
 284       mess43(1,10) = '. dont aretes isolees                      '
 285       mess43(1,11) = '. dont aretes de bord de regions 2D        '
 286       mess43(1,12) = '. dont aretes internes aux faces/volumes   '
 287 c
 288       mess43(1,20) = '. dont triangles de regions 2D             '
 289       mess43(1,21) = '. dont triangles de bord                   '
 290       mess43(1,22) = '. dont triangles internes aux volumes      '
 291 c
 292       mess43(1,30) = '. dont quadrangles de regions 2D           '
 293       mess43(1,31) = '. dont quadrangles de bord                 '
 294       mess43(1,32) = '. dont quadrangles internes aux volumes    '
 295 c
 296       mess43(1,60) = 'Paires de                                  '
 297 c                     1234567890123456789012345678901234567890123
 298 c
 299       mess54(2,1) =
 300      > '   The mesh implies homologous condition.             '
 301 c
 302       mess43(2,1) = 'Total number                               '
 303       mess43(2,3) = '. included vertices of edges               '
 304       mess43(2,4) = '. included centers of edges                '
 305       mess43(2,5) = '. included internal nodes                  '
 306       mess43(2,6) = '. included isolated nodes                  '
 307       mess43(2,7) = '. included only ignored meshes nodes       '
 308       mess43(2,8) = '. included only mesh-point nodes           '
 309 c
 310       mess43(2,10) = '. included isolated edges                  '
 311       mess43(2,11) = '. included boundaries of 2D areas          '
 312       mess43(2,12) = '. included internal in faces/volumes       '
 313 c
 314       mess43(2,20) = '. included triangles of 2D areas           '
 315       mess43(2,21) = '. included boundary triangles              '
 316       mess43(2,22) = '. included internal triangles              '
 317 c
 318       mess43(2,30) = '. included quadrangles of 2D areas         '
 319       mess43(2,31) = '. included boundary quadrangles            '
 320       mess43(2,32) = '. included internal quadrangles            '
 321 c
 322       mess43(2,60) = 'Pairs of                                   '
 323 c                     1234567890123456789012345678901234567890123
 324 c
 325 10100 format(/,5x,60('*'))
 326 10200 format(  5x,60('*'))
 327 c
 328 11100 format(  5x,'*  ',a54,'  *')
 329 11200 format(  5x,'* ',21x,a14,21x,' *')
 330 c
 331 12200 format(  5x,'* ',a43,' * ', i10,' *')
 332 c
 333 #include "impr03.h"
 334 c
 335       codret = 0
 336 c
 337 #ifdef _DEBUG_HOMARD_
 338       write (ulsort,90002) 'lg de tabaui = nivsup', nivsup
 339 #endif
 340 c
 341 c====
 342 c 2. noeuds
 343 c====
 344 c
 345 #ifdef _DEBUG_HOMARD_
 346       write (ulsort,90002) '2. nbnoto',nbnoto
 347 #endif
 348 c
 349       nbeqno = 0
 350       ideb = nctfno - ncefno + 1
 351       ifin = nctfno
 352 c
 353       do 21 , lenoeu = 1, nbnoto
 354 c
 355         do 211 , iaux = ideb , ifin
 356           if ( cfanoe(iaux,famnoe(lenoeu)).ne.0 ) then
 357              nbeqno = nbeqno + 1
 358           endif
 359   211   continue
 360 c
 361    21 continue
 362 c
 363       write (ulbila,10100)
 364       write (ulbila,11200) mess14(langue,4,-1)
 365       write (ulbila,10200)
 366       write (ulbila,12200) mess43(langue,1), nbnoto
 367       if ( degre.eq.2 .or.
 368      >     nbnois.ne.0 .or. nbnoei.ne.0 .or. nbnomp.ne.0 ) then
 369         write (ulbila,12200) mess43(langue,3), nbnop1
 370       endif
 371       if ( degre.eq.2 ) then
 372         write (ulbila,12200) mess43(langue,4), nbnop2
 373       endif
 374       if ( mod(mailet,2).eq.0 .or.
 375      >     mod(mailet,3).eq.0 .or.
 376      >     mod(mailet,5).eq.0 ) then
 377         write (ulbila,12200) mess43(langue,5), nbnoim
 378       endif
 379       if ( nbnois.ne.0 ) then
 380         write (ulbila,12200) mess43(langue,6), nbnois
 381       endif
 382       if ( nbnoei.ne.0 ) then
 383         write (ulbila,12200) mess43(langue,7), nbnoei
 384       endif
 385       if ( nbnomp.ne.0 ) then
 386         write (ulbila,12200) mess43(langue,8), nbnomp
 387       endif
 388       write (ulbila,10200)
 389 c
 390 c====
 391 c 3. mailles-points
 392 c====
 393 c
 394 #ifdef _DEBUG_HOMARD_
 395       write (ulsort,90002) '3. nbmpto',nbmpto
 396 #endif
 397 c
 398       if ( nbmpto.ne.0 ) then
 399 c
 400         nbmapo = 0
 401         nbeqmp = 0
 402         ideb = nctfmp - ncefmp + 1
 403         ifin = nctfmp
 404 c
 405         do 31 , lamapo = 1, nbmpto
 406 c
 407           if ( cfampo(cotyel,fammpo(lamapo)).ne.0 ) then
 408 c
 409           nbmapo = nbmapo + 1
 410 c
 411           do 311 , iaux = ideb , ifin
 412             if ( cfampo(iaux,fammpo(lamapo)).ne.0 ) then
 413                nbeqmp = nbeqmp + 1
 414             endif
 415   311     continue
 416 c
 417           endif
 418 c
 419    31   continue
 420 c
 421         if ( nbmapo.ne.0 ) then
 422 c
 423           write (ulbila,10100)
 424           write (ulbila,11200) mess14(langue,4,0)
 425           write (ulbila,10200)
 426           write (ulbila,12200) mess43(langue,1), nbmapo
 427           write (ulbila,10200)
 428 c
 429         endif
 430 c
 431       endif
 432 c
 433 c====
 434 c 4. aretes
 435 c====
 436 c    on rappelle que la caracteristique numero cotyel des aretes est
 437 c    nulle si ce n'etait pas une maille du calcul.
 438 c    si c'est une maille de calcul, la caracteristique vaut le type
 439 c    correspondant a celui du code de calcul associe.
 440 c
 441 c on definit une arete de bord comme etant une arete ayant :
 442 c   . une seule face voisine,
 443 c   . deux faces voisines :
 444 c     . deux triangles dont l'un est le pere de l'autre : cas du
 445 c       decoupage de conformite provenant de l'arete de bord ; cela n'a
 446 c       lieu qu'avec des homologues.
 447 c     . un triangle et un quadrangle qui en est le pere des autres : cas
 448 c       du decoupage non conforme d'un quadrangle de bord.
 449 c
 450 #ifdef _DEBUG_HOMARD_
 451       write (ulsort,90002) '4. nbarto',nbarto
 452 #endif
 453 c
 454       nbaret = 0
 455       nbarbt = 0
 456       nbarit = 0
 457       nbeqar = 0
 458       ideb = nctfar - ncefar + 1
 459       ifin = nctfar
 460 c
 461       do 41 , larete = 1, nbarto
 462 c
 463         if ( cfaare(cotyel,famare(larete)).ne.0 ) then
 464 c
 465         etat = mod(hetare(larete) , 10 )
 466 c
 467         if ( etat.eq.0 ) then
 468 c
 469         nbaret = nbaret + 1
 470         arbord = .false.
 471 c
 472         if ( posifa(larete-1)+2.eq.posifa(larete) ) then
 473           pos = posifa(larete)
 474           fac1 = facare(pos-1)
 475           fac2 = facare(pos)
 476           if ( fac1.gt.0 .and. fac2.gt.0 ) then
 477             vois1 = min(fac1,fac2)
 478             vois2 = max(fac1,fac2)
 479             if ( pertri(vois2).eq.vois1 ) then
 480               arbord = .true.
 481             endif
 482           elseif ( fac1.gt.0 .and. fac2.lt.0 ) then
 483             if ( pertri(fac1).eq.fac2 ) then
 484               arbord = .true.
 485             endif
 486           elseif ( fac1.lt.0 .and. fac2.gt.0 ) then
 487             if ( pertri(fac2).eq.fac1 ) then
 488               arbord = .true.
 489             endif
 490           endif
 491         elseif ( posifa(larete-1)+1.eq.posifa(larete) ) then
 492           arbord = .true.
 493         elseif ( posifa(larete-1)+1.gt.posifa(larete) ) then
 494           nbarit = nbarit +1
 495         endif
 496 c
 497         if ( arbord ) then
 498           nbarbt = nbarbt +1
 499         endif
 500 c
 501         do 411 , iaux = ideb , ifin
 502           if ( cfaare(iaux,famare(larete)).ne.0 ) then
 503              nbeqar = nbeqar + 1
 504           endif
 505   411   continue
 506 c
 507         endif
 508 c
 509         endif
 510 c
 511    41 continue
 512 c
 513       if ( nbaret.ne.0 ) then
 514 c
 515         write (ulbila,10100)
 516         write (ulbila,11200) mess14(langue,4,1)
 517         write (ulbila,10200)
 518         write (ulbila,12200) mess43(langue,1), nbaret
 519         if ( nbtrto.ne.0 .or. nbquto.ne.0 ) then
 520           write (ulbila,12200) mess43(langue,10), nbarit
 521           write (ulbila,12200) mess43(langue,11), nbarbt
 522           write (ulbila,12200) mess43(langue,12), nbaret-nbarit-nbarbt
 523         endif
 524         write (ulbila,10200)
 525 c
 526       endif
 527 c
 528 c====
 529 c 5. triangles
 530 c====
 531 c    on rappelle que la caracteristique numero 2 des faces est nulle si
 532 c    ce n'etait pas une maille du calcul.
 533 c    si c'est une maille de calcul, la caracteristique vaut le type
 534 c    correspondant a celui du code de calcul associe.
 535 c    Un triangle de bord est un triangle ayant un et un seul
 536 c    volume voisin.
 537 c    Le stockage etant different de la dimension deux, le tableau
 538 c    voltri ne garde que le volume fils.
 539 c
 540 #ifdef _DEBUG_HOMARD_
 541       write (ulsort,90002) '5. nbtrto',nbtrto
 542 #endif
 543 c
 544       if ( nbtrto.ne.0 ) then
 545 c
 546         do 51 , iaux = -nivsup-1, nivsup+1
 547           tabaui(iaux) = 0
 548    51   continue
 549 c
 550         nbvolu = nbteto + nbpyto + nbpeto
 551         jaux = 0
 552         nbfabt = 0
 553         nbfavt = 0
 554         nbeqtr = 0
 555         ideb = nctftr - nceftr + 1
 556         ifin = nctftr
 557 c
 558         do 52 , letria = 1, nbtrto
 559 c
 560           if ( cfatri(cotyel,famtri(letria)).ne.0 ) then
 561 c
 562             etat = mod(hettri(letria) , 10 )
 563 c
 564             if ( etat.eq.0 ) then
 565 c
 566             jaux = jaux + 1
 567             iaux = nivtri(letria)
 568             if ( letria.gt.nbtrpe ) then
 569               iaux = -iaux
 570             endif
 571             tabaui(iaux) = tabaui(iaux) + 1
 572 c
 573             if ( nbvolu.ne.0 ) then
 574 c
 575               if ( voltri(1,letria).ne.0 ) then
 576                 if ( voltri(2,letria).eq.0 ) then
 577                   nbfabt = nbfabt + 1
 578                 else
 579                   nbfavt = nbfavt + 1
 580                 endif
 581               endif
 582 c
 583             endif
 584 c
 585             do 521 , iaux = ideb , ifin
 586               if ( cfatri(iaux,famtri(letria)).ne.0 ) then
 587                  nbeqtr = nbeqtr + 1
 588               endif
 589   521       continue
 590 c
 591             endif
 592 c
 593           endif
 594 c
 595    52   continue
 596 c
 597         if ( jaux.ne.0 ) then
 598 c
 599           write (ulbila,10100)
 600           write (ulbila,11200) mess14(langue,4,2)
 601           write (ulbila,10200)
 602           write (ulbila,12200) mess43(langue,1), jaux
 603           if ( nbvolu.ne.0 ) then
 604             write (ulbila,12200) mess43(langue,20), jaux-nbfabt-nbfavt
 605             write (ulbila,12200) mess43(langue,21), nbfabt
 606             write (ulbila,12200) mess43(langue,22), nbfavt
 607           endif
 608 c
 609           if ( nbiter.ge.1 ) then
 610             call utb07b ( tabaui, ulbila,
 611      >                    ulsort, langue, codret )
 612           endif
 613 c
 614           write (ulbila,10200)
 615 c
 616         endif
 617 c
 618       endif
 619 c
 620 c====
 621 c 6. quadrangles
 622 c====
 623 c    on rappelle que la caracteristique numero 2 des faces est nulle si
 624 c    ce n'etait pas une maille du calcul.
 625 c    si c'est une maille de calcul, la caracteristique vaut le type
 626 c    correspondant a celui du code de calcul associe.
 627 c    Un quadrangle de bord est un quadrangle ayant un et un seul
 628 c    volume voisin.
 629 c    Le stockage etant different de la dimension deux, le tableau
 630 c    volqua ne garde que le volume fils.
 631 c
 632 #ifdef _DEBUG_HOMARD_
 633       write (ulsort,90002) '6. nbquto',nbquto
 634 #endif
 635 c
 636       if ( nbquto.ne.0 ) then
 637 c
 638         do 61 , iaux = -nivsup-1, nivsup+1
 639           tabaui(iaux) = 0
 640    61   continue
 641 c
 642         nbvolu = nbheto + nbpyto + nbpeto
 643         jaux = 0
 644         nbfabt = 0
 645         nbfavt = 0
 646         nbeqqu = 0
 647         ideb = nctfqu - ncefqu + 1
 648         ifin = nctfqu
 649 c
 650         do 62 , lequad = 1, nbquto
 651 c
 652           if ( cfaqua(cotyel,famqua(lequad)).ne.0 ) then
 653 c
 654             etat = mod(hetqua(lequad),100)
 655 c
 656             if ( etat.eq.0 ) then
 657 c
 658             jaux = jaux + 1
 659             iaux = nivqua(lequad)
 660             if ( lequad.gt.nbqupe ) then
 661               iaux = -iaux
 662             endif
 663             tabaui(iaux) = tabaui(iaux) + 1
 664 c
 665             if ( nbvolu.ne.0 ) then
 666 c
 667               if ( volqua(1,lequad).ne.0 ) then
 668                 if ( volqua(2,lequad).eq.0 ) then
 669                   nbfabt = nbfabt + 1
 670                 else
 671                   nbfavt = nbfavt + 1
 672                 endif
 673               endif
 674 c
 675             endif
 676 c
 677             do 621 , iaux = ideb , ifin
 678               if ( cfaqua(iaux,famqua(lequad)).ne.0 ) then
 679                  nbeqqu = nbeqqu + 1
 680               endif
 681   621       continue
 682 c
 683             endif
 684 c
 685           endif
 686 c
 687    62   continue
 688 c
 689         if ( jaux.ne.0 ) then
 690 c
 691           write (ulbila,10100)
 692           write (ulbila,11200) mess14(langue,4,4)
 693           write (ulbila,10200)
 694           write (ulbila,12200) mess43(langue,1), jaux
 695           if ( nbvolu.ne.0 ) then
 696             write (ulbila,12200) mess43(langue,30), jaux-nbfabt-nbfavt
 697             write (ulbila,12200) mess43(langue,31), nbfabt
 698             write (ulbila,12200) mess43(langue,32), nbfavt
 699           endif
 700 c
 701           if ( nbiter.ge.1 ) then
 702             call utb07b ( tabaui, ulbila,
 703      >                    ulsort, langue, codret )
 704           endif
 705 c
 706           write (ulbila,10200)
 707 c
 708         endif
 709 c
 710       endif
 711 c
 712 c====
 713 c 7. tetraedres
 714 c====
 715 c
 716 #ifdef _DEBUG_HOMARD_
 717       write (ulsort,90002) '7. nbteto, nbtepe, nbtecf, nbteca',
 718      >                     nbteto, nbtepe, nbtecf, nbteca
 719 #endif
 720 c
 721       if ( nbteto.ne.0 ) then
 722 c
 723         do 70 , iaux = -nivsup-1, nivsup+1
 724           tabaui(iaux) = 0
 725    70   continue
 726 c
 727         jaux = 0
 728 c
 729 c 7.1. ==> Les tetraedres de depart ou issus d'un decoupage en 8
 730 c          Les faces sont toutes du meme niveau
 731 c          Remarque : ils sont toujours decrits par faces
 732 c
 733         do 71 , letetr = 1, nbtepe
 734 c
 735           if ( cfatet(cotyel,famtet(letetr)).ne.0 ) then
 736 c
 737           etat = mod(hettet(letetr),100)
 738 c
 739           if ( etat.eq.0 ) then
 740 c
 741           jaux = jaux + 1
 742           iaux = nivtri(tritet(letetr,1))
 743           tabaui(iaux) = tabaui(iaux) + 1
 744 c
 745           endif
 746 c
 747           endif
 748 c
 749    71   continue
 750 cgn      write (ulsort,90002) 'jaux', jaux
 751 c
 752 c 7.2. ==> Les tetraedres issus d'un decoupage de conformite
 753 c          Remarque : ils sont toujours actifs
 754 c
 755         do 72 , letetr = nbtepe+1 , nbteto
 756 c
 757           call utntet ( letetr, niveau,
 758      >                  tritet, pertet, pthepe,
 759      >                  nivtri, nivqua,
 760      >                  quahex, facpen )
 761 c
 762           jaux = jaux + 1
 763           iaux = -int(niveau) - 1
 764           tabaui(iaux) = tabaui(iaux) + 1
 765 c
 766    72   continue
 767 cgn      write (ulsort,90002) 'jaux', jaux
 768 c
 769         if ( jaux.ne.0 ) then
 770 c
 771           write (ulbila,10100)
 772           write (ulbila,11200) mess14(langue,4,3)
 773           write (ulbila,10200)
 774           write (ulbila,12200) mess43(langue,1), jaux
 775 c
 776           if ( nbiter.ge.1 ) then
 777             call utb07b ( tabaui, ulbila,
 778      >                    ulsort, langue, codret )
 779           endif
 780 c
 781           write (ulbila,10200)
 782 c
 783         endif
 784 c
 785       endif
 786 c
 787 c====
 788 c 8. hexaedres
 789 c====
 790 c
 791 #ifdef _DEBUG_HOMARD_
 792       write (ulsort,90002) '8. nbheto, nbhecf',nbheto, nbhecf
 793 #endif
 794 c
 795       if ( nbheto.ne.0 ) then
 796 c
 797         do 80 , iaux = -nivsup-1, nivsup+1
 798           tabaui(iaux) = 0
 799    80   continue
 800 c
 801         jaux = 0
 802 c
 803 c 8.1. ==> Les hexaedres de depart ou issus d'un decoupage en 8
 804 c          Les faces sont toutes du meme niveau
 805 c          Remarque : ils sont toujours decrits par faces
 806 c
 807         do 81 , lehexa = 1, nbhepe
 808 c
 809           if ( cfahex(cotyel,famhex(lehexa)).ne.0 ) then
 810 c
 811           etat = mod(hethex(lehexa),1000)
 812 c
 813           if ( etat.eq.0 ) then
 814 c
 815           jaux = jaux + 1
 816           iaux = nivqua(quahex(lehexa,1))
 817           tabaui(iaux) = tabaui(iaux) + 1
 818 c
 819           endif
 820 c
 821           endif
 822 c
 823    81   continue
 824 c
 825 c 8.2. ==> Les hexaedres issus d'un decoupage de conformite
 826 c          Remarque : ils sont toujours actifs
 827 c
 828         do 82 , lehexa = nbhepe+1 , nbheto
 829 c
 830           call utnhex ( lehexa, niveau,
 831      >                  quahex, perhex,
 832      >                  nivqua )
 833 c
 834           jaux = jaux + 1
 835           iaux = -int(niveau) - 1
 836           tabaui(iaux) = tabaui(iaux) + 1
 837 c
 838    82   continue
 839 c
 840         jaux = jaux + nbheca
 841 c
 842         if ( jaux.ne.0 ) then
 843 c
 844           write (ulbila,10100)
 845           write (ulbila,11200) mess14(langue,4,6)
 846           write (ulbila,10200)
 847           write (ulbila,12200) mess43(langue,1), jaux
 848 c
 849           if ( nbiter.ge.1 ) then
 850             call utb07b ( tabaui, ulbila,
 851      >                    ulsort, langue, codret )
 852           endif
 853 c
 854           write (ulbila,10200)
 855 c
 856         endif
 857 c
 858       endif
 859 c
 860 c====
 861 c 9. pyramides
 862 c====
 863 c
 864 #ifdef _DEBUG_HOMARD_
 865       write (ulsort,90002) '9. nbpyto, nbpype, nbpycf, nbpyca',
 866      >                     nbpyto, nbpype, nbpycf, nbpyca
 867 #endif
 868 c
 869       if ( nbpyto.ne.0 ) then
 870 c
 871         do 90 , iaux = -nivsup-1, nivsup+1
 872           tabaui(iaux) = 0
 873    90   continue
 874 c
 875         jaux = 0
 876 c
 877 c 9.1. ==> Les pyramides de depart ou issues d'un decoupage en 8
 878 c          Les faces sont toutes du meme niveau
 879 c          Remarque : elles sont toujours decrites par faces
 880 c
 881         do 91 , lapyra = 1, nbpype
 882 cgn      write (ulsort,90002) 'pyramide',lapyra
 883 c
 884           if ( cfapyr(cotyel,fampyr(lapyra)).ne.0 ) then
 885 c
 886           etat = mod(hetpyr(lapyra),100)
 887 c
 888           if ( etat.eq.0 ) then
 889 c
 890           jaux = jaux + 1
 891           iaux = nivtri(facpyr(lapyra,1))
 892           tabaui(iaux) = tabaui(iaux) + 1
 893 c
 894           endif
 895 c
 896           endif
 897 c
 898    91   continue
 899 cgn      write (ulsort,90002) 'jaux', jaux
 900 cgn      write (ulsort,*) '************************'
 901 c
 902 c 9.2. ==> Les pyramides issues d'un decoupage de conformite
 903 c          Remarque : elles sont toujours actives
 904 c
 905         do 92 , lapyra = nbpype+1 , nbpyto
 906 cgn      write (ulsort,90002) 'pyramide',lapyra
 907 cgn      write (ulsort,90002) 'jaux',jaux
 908 c
 909           call utnpyr ( lapyra, niveau,
 910      >                  facpyr, perpyr, pphepe,
 911      >                  nivtri, nivqua,
 912      >                  quahex, facpen )
 913 c
 914           jaux = jaux + 1
 915           iaux = -int(niveau) - 1
 916           tabaui(iaux) = tabaui(iaux) + 1
 917 c
 918    92   continue
 919 cgn      write (ulsort,90002) 'jaux', jaux
 920 c
 921         if ( jaux.ne.0 ) then
 922 c
 923           write (ulbila,10100)
 924           write (ulbila,11200) mess14(langue,4,5)
 925           write (ulbila,10200)
 926           write (ulbila,12200) mess43(langue,1), jaux
 927 c
 928           if ( nbiter.ge.1 ) then
 929             call utb07b ( tabaui, ulbila,
 930      >                    ulsort, langue, codret )
 931           endif
 932 c
 933           write (ulbila,10200)
 934 c
 935         endif
 936 c
 937       endif
 938 c
 939 c====
 940 c 10. pentaedres
 941 c====
 942 c
 943 #ifdef _DEBUG_HOMARD_
 944       write (ulsort,90002) '10. nbpeto, nbpecf',nbpeto, nbpecf
 945 #endif
 946 c
 947       if ( nbpeto.ne.0 ) then
 948 c
 949         do 100 , iaux = -nivsup-1, nivsup+1
 950           tabaui(iaux) = 0
 951   100   continue
 952 c
 953         jaux = 0
 954 c
 955 c 10.1. ==> Les pentaedres de depart ou issus d'un decoupage en 8
 956 c          Les faces sont toutes du meme niveau
 957 c          Remarque : ils sont toujours decrits par faces
 958 c
 959         do 101 , lepent = 1, nbpepe
 960 c
 961           if ( cfapen(cotyel,fampen(lepent)).ne.0 ) then
 962 c
 963           etat = mod(hetpen(lepent),100)
 964 c
 965           if ( etat.eq.0 ) then
 966 c
 967           jaux = jaux + 1
 968           iaux = nivtri(facpen(lepent,1))
 969           tabaui(iaux) = tabaui(iaux) + 1
 970 c
 971           endif
 972 c
 973           endif
 974 c
 975   101   continue
 976 c
 977 c 10.2. ==> Les pentaedres issus d'un decoupage de conformite
 978 c          Remarque : ils sont toujours actifs
 979 c
 980         do 102 , lepent = nbpepe+1 , nbpeto
 981 c
 982           call utnpen ( lepent, niveau,
 983      >                  facpen, perpen,
 984      >                  nivtri, nivqua )
 985 c
 986           jaux = jaux + 1
 987           iaux = -int(niveau) - 1
 988           tabaui(iaux) = tabaui(iaux) + 1
 989 c
 990   102   continue
 991 c
 992         jaux = jaux + nbpeca
 993 c
 994         if ( jaux.ne.0 ) then
 995 c
 996           write (ulbila,10100)
 997           write (ulbila,11200) mess14(langue,4,7)
 998           write (ulbila,10200)
 999           write (ulbila,12200) mess43(langue,1), jaux
1000 c
1001           if ( nbiter.ge.1 ) then
1002             call utb07b ( tabaui, ulbila,
1003      >                    ulsort, langue, codret )
1004           endif
1005 c
1006           write (ulbila,10200)
1007 c
1008         endif
1009 c
1010       endif
1011 c
1012 c====
1013 c 11. reperage des homologues
1014 c====
1015 c
1016 #ifdef _DEBUG_HOMARD_
1017       write (ulsort,90002) '11. homolo',homolo
1018 #endif
1019 c
1020       if ( homolo.ne.0 ) then
1021 c
1022         write (ulbila,10100)
1023         write (ulbila,11100) mess54(langue,1)
1024         write (ulbila,10200)
1025         saux43 = mess43(langue,60)
1026         if (nbeqno.gt.0) then
1027           saux43(11:24) = mess14(langue,3,-1)
1028           write (ulbila,12200) saux43, nbeqno/2
1029         endif
1030         if (nbeqmp.gt.0) then
1031           saux43(11:24) = mess14(langue,3,0)
1032           write (ulbila,12200) saux43, nbeqmp/2
1033         endif
1034         if (nbeqar.gt.0) then
1035           saux43(11:24) = mess14(langue,3,1)
1036           write (ulbila,12200) saux43, nbeqar/2
1037         endif
1038         if ( nbeqtr.gt.0 ) then
1039           saux43(11:24) = mess14(langue,3,2)
1040           write (ulbila,12200) saux43, nbeqtr/2
1041         endif
1042         if ( nbeqqu.gt.0 ) then
1043           saux43(11:24) = mess14(langue,3,4)
1044           write (ulbila,12200) saux43, nbeqqu/2
1045         endif
1046         write (ulbila,10200)
1047 c
1048       endif
1049 c
1050 c====
1051 c 12. la fin
1052 c====
1053 c
1054 #ifdef _DEBUG_HOMARD_
1055       write (ulsort,90002) '12. codret',codret
1056 #endif
1057 c
1058       if ( codret.ne.0 ) then
1059 c
1060 #include "envex2.h"
1061 c
1062       write (ulsort,texte(langue,1)) 'Sortie', nompro
1063       write (ulsort,texte(langue,2)) codret
1064 c
1065       endif
1066 c
1067 #ifdef _DEBUG_HOMARD_
1068       write (ulsort,texte(langue,1)) 'Sortie', nompro
1069       call dmflsh (iaux)
1070 #endif
1071 c
1072       end