src/tool/AP_Conversion/pcmac1.F

   1       subroutine pcmac1 ( nbele0,
   2      >                    coonoe, hetnoe, ancnoe, trav1a,
   3      >                    noempo, hetmpo,
   4      >                    somare, np2are, hetare,
   5      >                    aretri, hettri, nintri,
   6      >                    arequa, hetqua, ninqua,
   7      >                    tritet, cotrte, aretet, hettet,
   8      >                    quahex, coquhe, arehex, hethex,
   9      >                    ninhex,
  10      >                    facpyr, cofapy, arepyr, hetpyr,
  11      >                    facpen, cofape, arepen, hetpen,
  12      >                    famnoe, cfanoe, fammpo, cfampo,
  13      >                    famare, cfaare,
  14      >                    famtri, cfatri, famqua, cfaqua,
  15      >                    famtet, cfatet, famhex, cfahex,
  16      >                    fampyr, cfapyr, fampen, cfapen,
  17      >                    nnosca, nnosho, nmpsca, nmpsho,
  18      >                    narsca, narsho,
  19      >                    ntrsca, ntrsho, nqusca, nqusho,
  20      >                    ntesca, ntesho, nhesca, nhesho,
  21      >                    npysca, npysho, npesca, npesho,
  22      >                    dimcst, coocst, coonca, fameno,
  23      >                    famele, noeele, typele,
  24      >                    fmdeig, noeeig,
  25      >                    noeord, deraff,
  26      >                    ulsort, langue, codret )
  27 c ______________________________________________________________________
  28 c
  29 c                             H O M A R D
  30 c
  31 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  32 c
  33 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  34 c aupres des huissiers de justice Simart et Lavoir a Clamart
  35 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  36 c aupres des huissiers de justice
  37 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  38 c
  39 c    HOMARD est une marque deposee d'Electricite de France
  40 c
  41 c Copyright EDF 1996
  42 c Copyright EDF 1998
  43 c Copyright EDF 2002
  44 c Copyright EDF 2020
  45 c ______________________________________________________________________
  46 c
  47 c    aPres adaptation - Conversion - MAillage Connectivite - phase 1
  48 c     -                 -            --       -                    -
  49 c ______________________________________________________________________
  50 c
  51 c remarque : on s'arrange pour que les mailles externes soient
  52 c            numerotees dans cet ordre :
  53 c            . les tetraedres
  54 c            . les triangles
  55 c            . les aretes
  56 c            . les mailles-points
  57 c            . les quadrangles
  58 c            . les hexaedres
  59 c            . les pyramides
  60 c            . les pentaedres
  61 c ______________________________________________________________________
  62 c .        .     .        .                                            .
  63 c .  nom   . e/s . taille .           description                      .
  64 c .____________________________________________________________________.
  65 c . nbele0 . e   .   1    . estimation du nombre d'elements            .
  66 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  67 c .        .     . * sdim .                                            .
  68 c . hetnoe . e   . nbnoto . historique de l'etat des noeuds            .
  69 c . noempo . e   . nbmpto . numeros des noeuds associes aux mailles    .
  70 c . hetmpo . e   . nbmpto . historique de l'etat des mailles-points    .
  71 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  72 c . np2are . e   . nbarto . numero du noeud p2 milieu d'arete          .
  73 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  74 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  75 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  76 c . nintri . e   . nbtrto . noeud interne au triangle                  .
  77 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  78 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  79 c . ninqua . e   . nbquto . noeud interne au quadrangle                .
  80 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  81 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  82 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  83 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  84 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  85 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  86 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  87 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  88 c . ninhex . e   . nbheto . noeud interne a l'hexaedre                 .
  89 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  90 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  91 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  92 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  93 c . facpen . e   .nbpecf*5. numeros des faces des pentaedres           .
  94 c . cofape . e   .nbpecf*5. codes des faces des pentaedres             .
  95 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  96 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  97 c . cfanoe . e   . nctfno*. codes des familles des noeuds              .
  98 c .        .     . nbnoto .   1 : famille MED                          .
  99 c .        .     .        . + l : appartenance a l'equivalence l       .
 100 c . fammpo . e   . nbmpto . famille des mailles-points                 .
 101 c . cfampo . e   . nctfmp*. codes des familles des mailles-points      .
 102 c .        .     . nbfmpo .   1 : famille MED                          .
 103 c .        .     .        .   2 : type de maille-point                 .
 104 c .        .     .        .   3 : famille des sommets                  .
 105 c .        .     .        . + l : appartenance a l'equivalence l       .
 106 c . famare . e   . nbarto . famille des aretes                         .
 107 c . cfaare . e   . nctfar*. codes des familles des aretes              .
 108 c .        .     . nbfare .   1 : famille MED                          .
 109 c .        .     .        .   2 : type de segment                      .
 110 c .        .     .        .   3 : orientation                          .
 111 c .        .     .        .   4 : famille d'orientation inverse        .
 112 c .        .     .        .   5 : numero de ligne de frontiere         .
 113 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
 114 c .        .     .        . <= 0 si non concernee                      .
 115 c .        .     .        .   6 : famille frontiere active/inactive    .
 116 c .        .     .        .   7 : numero de surface de frontiere       .
 117 c .        .     .        . + l : appartenance a l'equivalence l       .
 118 c . famtri . e   . nbtrto . famille des triangles                      .
 119 c . cfatri . e   . nctftr*. codes des familles des triangles           .
 120 c .        .     . nbftri .   1 : famille MED                          .
 121 c .        .     .        .   2 : type de triangle                     .
 122 c .        .     .        .   3 : numero de surface de frontiere       .
 123 c .        .     .        .   4 : famille des aretes internes apres raf.
 124 c .        .     .        . + l : appartenance a l'equivalence l       .
 125 c . famqua . e   . nbquto . famille des quadrangles                    .
 126 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
 127 c .        .     . nbfqua .   1 : famille MED                          .
 128 c .        .     .        .   2 : type de quadrangle                   .
 129 c .        .     .        .   3 : numero de surface de frontiere       .
 130 c .        .     .        .   4 : famille des aretes internes apres raf.
 131 c .        .     .        .   5 : famille des triangles de conformite  .
 132 c .        .     .        .   6 : famille de sf active/inactive        .
 133 c .        .     .        . + l : appartenance a l'equivalence l       .
 134 c . famtet . e   . nbteto . famille des tetraedres                     .
 135 c . cfatet .     . nctfte. codes des familles des tetraedres          .
 136 c .        .     . nbftet .   1 : famille MED                          .
 137 c .        .     .        .   2 : type de tetraedres                   .
 138 c . famhex . e   . nbheto . famille des hexaedres                      .
 139 c . cfahex .     . nctfhe. codes des familles des hexaedres            .
 140 c .        .     . nbfhex .   1 : famille MED                          .
 141 c .        .     .        .   2 : type d'hexaedres                     .
 142 c .        .     .        .   3 : famille des tetraedres de conformite .
 143 c .        .     .        .   4 : famille des pyramides de conformite  .
 144 c . fampyr . e   . nbpyto . famille des pyramides                      .
 145 c . cfapyr .     . nctfpy. codes des familles des pyramides            .
 146 c .        .     . nbfpyr .   1 : famille MED                          .
 147 c .        .     .        .   2 : type de pyramides                    .
 148 c . fampen . e   . nbpeto . famille des pentaedres                     .
 149 c . cfapen .     . nctfpe. codes des familles des pentaedres          .
 150 c .        .     . nbfpen .   1 : famille MED                          .
 151 c .        .     .        .   2 : type de pentaedres                   .
 152 c .        .     .        .   3 : famille des tetraedres de conformite .
 153 c .        .     .        .   4 : famille des pyramides de conformite  .
 154 c . nnosca .  s  . rsnoto . numero des noeuds du code de calcul        .
 155 c . nnosho .  s  . rsnoac . numero des noeuds dans HOMARD              .
 156 c . nmpsca .  s  . rsmpto . numero des mailles-points du calcul        .
 157 c . nmpsho .  s  . rsmpac . numero des mailles-points dans HOMARD      .
 158 c . narsca .  s  . rsarto . numero des aretes du calcul                .
 159 c . narsho .  s  . rsarac . numero des aretes dans HOMARD              .
 160 c . ntrsca .  s  . rstrto . numero des triangles du calcul             .
 161 c . ntrsho .  s  . rstrac . numero des triangles dans HOMARD           .
 162 c . nqusca .  s  . rsquto . numero des quadrangles du calcul           .
 163 c . nqusho .  s  . rsquac . numero des quadrangles dans HOMARD         .
 164 c . ntesca .  s  . rsteto . numero des tetraedres du calcul            .
 165 c . ntesho .  s  . rsteac . numero des tetraedres dans HOMARD          .
 166 c . nhesho .  s  . reheac . numero des hexaedres dans HOMARD           .
 167 c . nhesca .  s  . rsheto . numero des hexaedres dans le calcul        .
 168 c . npysho .  s  . repyac . numero des pyramides dans HOMARD           .
 169 c . npysca .  s  . rspyto . numero des pyramides dans le calcul sortie .
 170 c . npesho .  s  . repeac . numero des pentaedres dans HOMARD          .
 171 c . npesca .  s  . rspeto . numero des pentaedres dans le calcul       .
 172 c . dimcst . e   .    1   . dimension de la coordonnee constante       .
 173 c .        .     .        . eventuelle, 0 si toutes varient            .
 174 c . coocst . e   .   11   . 1 : coordonnee constante eventuelle        .
 175 c .        .     .        . 2, 3, 4 : xmin, ymin, zmin                 .
 176 c .        .     .        . 5, 6, 7 : xmax, ymax, zmax                 .
 177 c .        .     .        . 8, 9, 10 : -1 si constant, max-min sinon   .
 178 c .        .     .        . 11 : max des (max-min)                     .
 179 c . coonca .   s . nbnoto . coordonnees des noeuds dans le calcul      .
 180 c .        .     . *sdimca.                                            .
 181 c . fameno .   s . nbnoto . famille med des noeuds                     .
 182 c . famele .   s . nbele0 . famille med des elements                   .
 183 c . noeele .   s . nbele0 . noeuds des elements                        .
 184 c .        .     . *nbmane.                                            .
 185 c . typele .   s . nbele0 . type des elements                          .
 186 c . noeord . e   .   1    . vrai si les noeuds sont ordonnes           .
 187 c .        .     .        . faux si sans importance                    .
 188 c . noeeig . e   .nbelig**. noeuds des elements                        .
 189 c . fmdeig . e   . nbelig . famille med des elements                   .
 190 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
 191 c . langue . e   .    1   . langue des messages                        .
 192 c .        .     .        . 1 : francais, 2 : anglais                  .
 193 c . codret . es  .    1   . code de retour des modules                 .
 194 c .        .     .        . 0 : pas de probleme                        .
 195 c .        .     .        . 1 : probleme                               .
 196 c ______________________________________________________________________
 197 c
 198 c====
 199 c 0. declarations et dimensionnement
 200 c====
 201 c
 202 c 0.1. ==> generalites
 203 c
 204       implicit none
 205       save
 206 c
 207       character*6 nompro
 208       parameter ( nompro = 'PCMAC1' )
 209 c
 210 #include "nblang.h"
 211 c
 212 c 0.2. ==> communs
 213 c
 214 #include "envex1.h"
 215 c
 216 #include "envca1.h"
 217 c
 218 #include "nbfami.h"
 219 #include "nombmp.h"
 220 #include "nombar.h"
 221 #include "nombtr.h"
 222 #include "nombqu.h"
 223 #include "nombno.h"
 224 #include "nombte.h"
 225 #include "nombhe.h"
 226 #include "nombpy.h"
 227 #include "nombpe.h"
 228 c
 229 #include "nombsr.h"
 230 #include "nbutil.h"
 231 c
 232 #include "dicfen.h"
 233 c
 234 c 0.3. ==> arguments
 235 c
 236       integer nbele0
 237       integer dimcst
 238 c
 239       double precision coocst(11)
 240       double precision coonoe(nbnoto,sdim), coonca(nbnoto,sdimca)
 241 c
 242       integer hetnoe(nbnoto), ancnoe(nbnoto), trav1a(nbnoto)
 243       integer noempo(nbmpto), hetmpo(nbmpto)
 244       integer somare(2,nbarto), np2are(nbarto)
 245       integer hetare(nbarto)
 246       integer aretri(nbtrto,3), hettri(nbtrto), nintri(nbtrto)
 247       integer arequa(nbquto,4), hetqua(nbquto), ninqua(nbquto)
 248       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 249       integer hettet(nbteto)
 250       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 251       integer hethex(nbheto), ninhex(nbheto)
 252       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 253       integer hetpyr(nbpyto)
 254       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 255       integer hetpen(nbpeto)
 256 c
 257       integer cfanoe(nctfno,nbfnoe), famnoe(nbnoto)
 258       integer cfampo(nctfmp,nbfmpo), fammpo(nbmpto)
 259       integer cfaare(nctfar,nbfare), famare(nbarto)
 260       integer cfatri(nctftr,nbftri), famtri(nbtrto)
 261       integer cfaqua(nctfqu,nbfqua), famqua(nbquto)
 262       integer cfatet(nctfte,nbftet), famtet(nbteto)
 263       integer cfahex(nctfhe,nbfhex), famhex(nbheto)
 264       integer cfapyr(nctfpy,nbfpyr), fampyr(nbpyto)
 265       integer cfapen(nctfpe,nbfpen), fampen(nbpeto)
 266 c
 267       integer nnosca(rsnoto), nnosho(rsnoac)
 268       integer nmpsca(rsmpto), nmpsho(nbele0)
 269       integer narsca(rsarto), narsho(nbele0)
 270       integer ntrsca(rstrto), ntrsho(nbele0)
 271       integer nqusca(rsquto), nqusho(nbele0)
 272       integer ntesca(rsteto), ntesho(nbele0)
 273       integer nhesca(rsheto), nhesho(nbele0)
 274       integer npysca(rspyto), npysho(nbele0)
 275       integer npesca(rspeto), npesho(nbele0)
 276 c
 277       integer fameno(nbnoto), famele(nbele0), noeele(nbele0,nbmane)
 278       integer typele(nbele0)
 279       integer fmdeig(nbelig)
 280       integer noeeig(nbelig,*)
 281 c
 282       logical noeord
 283       logical deraff
 284 c
 285       integer ulsort, langue, codret
 286 c
 287 c 0.4. ==> variables locales
 288 c
 289       integer elemen
 290       integer iaux
 291 c
 292       integer nbmess
 293       parameter ( nbmess = 10 )
 294       character*80 texte(nblang,nbmess)
 295 c
 296 c 0.5. ==> initialisations
 297 c ______________________________________________________________________
 298 c
 299 c====
 300 c 1. initialisations
 301 c====
 302 c
 303 #include "impr01.h"
 304 c
 305 #ifdef _DEBUG_HOMARD_
 306       write (ulsort,texte(langue,1)) 'Entree', nompro
 307       call dmflsh (iaux)
 308 #endif
 309 c
 310       texte(1,4) = '(''Nombre de mailles calcule :'',i11)'
 311       texte(1,5) = '(''Nombre de mailles estime  :'',i11)'
 312       texte(1,6) = '(''Elements hierarchiques :'',i2)'
 313 c
 314       texte(2,4) = '(''Computed number of meshes  :'',i11)'
 315       texte(2,5) = '(''Estimated number of meshes :'',i11)'
 316       texte(2,6) = '(''Hierarchical elements :'',i2)'
 317 c
 318 #include "impr03.h"
 319 c
 320       nbquad = 0
 321       nbhexa = 0
 322       nbpent = 0
 323       nbpyra = 0
 324 c
 325 #ifdef _DEBUG_HOMARD_
 326       write (ulsort,texte(langue,6)) hierar
 327 #endif
 328 c
 329       codret = 0
 330 c
 331 c====
 332 c 2. les noeuds
 333 c====
 334 c
 335 #ifdef _DEBUG_HOMARD_
 336       write (ulsort,texte(langue,3)) 'PCMANO', nompro
 337 #endif
 338       call pcmano ( coonoe, hetnoe,
 339      >              famnoe, cfanoe,
 340      >              nnosca, nnosho,
 341      >              dimcst, coocst, sdimca, coonca,
 342      >              noeord,
 343      >              fameno,
 344      >              ulsort, langue, codret )
 345 c
 346 c====
 347 c 3. les mailles
 348 c    on rappelle que la caracteristique numero 2 d'une maille
 349 c    est nulle si ce n'etait pas une maille du calcul.
 350 c    si c'est une maille de calcul, la caracteristique vaut le type
 351 c    correspondant a celui du code de calcul associe.
 352 c
 353 c remarque : on s'arrange pour que les mailles externes soient
 354 c            numerotees dans cet ordre :
 355 c            . les tetraedres
 356 c            . les triangles
 357 c            . les aretes
 358 c            . les mailles-points
 359 c            . les quadrangles
 360 c            . les hexaedres
 361 c            . les pyramides
 362 c            . les pentaedres
 363 c            Cela est indispensable pour les algorithmes de
 364 c            conversion de solution et pour la gestion des equivalences
 365 c
 366 c remarque : dans le cas general, on ne prend que les mailles actives.
 367 c            mais dans le cas hierarchique, on prend tous les niveaux.
 368 c====
 369 #ifdef _DEBUG_HOMARD_
 370       write (ulsort,90002) '3. mailles ; codret', codret
 371 #endif
 372 c
 373       elemen = 0
 374 c
 375 c 3.1. ==> les tetraedres actifs
 376 #ifdef _DEBUG_HOMARD_
 377       write (ulsort,90002) '3.1. tetraedres ; codret', codret
 378 #endif
 379 c
 380       if ( codret.eq.0 ) then
 381 c
 382       if ( rsteto.eq.0 ) then
 383 c
 384         nbtetr = 0
 385 c
 386       else
 387 c
 388 #ifdef _DEBUG_HOMARD_
 389       write (ulsort,texte(langue,3)) 'PCMATE', nompro
 390 #endif
 391         call pcmate ( elemen, nbele0,
 392      >                somare, np2are,
 393      >                aretri,
 394      >                tritet, cotrte, aretet,
 395      >                hettet, famtet, cfatet,
 396      >                nnosca, ntesca, ntesho,
 397      >                famele, noeele, typele,
 398      >                ulsort, langue, codret )
 399 c
 400         nbtetr = elemen
 401 c
 402       endif
 403 c
 404       endif
 405 c
 406 c 3.2. ==> les mailles triangulaires :
 407 c                                 - triangles actifs en 2,5d
 408 c                                 - triangles actifs isoles en 3d,
 409 #ifdef _DEBUG_HOMARD_
 410       write (ulsort,90002) '3.2. triangles ; codret', codret
 411       write (ulsort,90002) 'nbtrac', nbtrac
 412 #endif
 413 c
 414       if ( codret.eq.0 ) then
 415 c
 416       if ( rstrto.eq.0 ) then
 417 c
 418         nbtria = 0
 419 c
 420       else
 421 c
 422 #ifdef _DEBUG_HOMARD_
 423       write (ulsort,texte(langue,3)) 'PCMATR', nompro
 424 #endif
 425         call pcmatr ( elemen, nbele0,
 426      >                somare, np2are,
 427      >                aretri, hettri, nintri,
 428      >                famtri, cfatri,
 429      >                nnosca, ntrsca, ntrsho,
 430      >                famele, noeele, typele,
 431      >                ulsort, langue, codret )
 432 c
 433         nbtria = elemen - nbtetr
 434 c
 435       endif
 436 c
 437       endif
 438 c
 439 c 3.3. ==> les poutres, c'est-a-dire les aretes isolees
 440 #ifdef _DEBUG_HOMARD_
 441       write (ulsort,90002) '3.3. aretes ; codret', codret
 442 #endif
 443 c
 444       if ( codret.eq.0 ) then
 445 c
 446       if ( rsarto.eq.0 ) then
 447 c
 448         nbsegm = 0
 449 c
 450       else
 451 c
 452 #ifdef _DEBUG_HOMARD_
 453       write (ulsort,texte(langue,3)) 'PCMAAR', nompro
 454 #endif
 455         call pcmaar ( elemen, nbele0,
 456      >                somare, np2are, hetare,
 457      >                famare, cfaare,
 458      >                nnosca, narsca, narsho,
 459      >                famele, noeele, typele,
 460      >                ulsort, langue, codret )
 461 c
 462         nbsegm = elemen - nbtetr - nbtria
 463 c
 464       endif
 465 c
 466       endif
 467 c
 468 c 3.4. ==> les mailles-points
 469 #ifdef _DEBUG_HOMARD_
 470       write (ulsort,90002) '3.4. mailles-points ; codret', codret
 471 #endif
 472 c
 473       if ( codret.eq.0 ) then
 474 c
 475       if ( rsmpto.eq.0 ) then
 476 c
 477         nbmapo = 0
 478 c
 479       else
 480 c
 481 #ifdef _DEBUG_HOMARD_
 482       write (ulsort,texte(langue,3)) 'PCMAMP', nompro
 483 #endif
 484         call pcmamp ( elemen, nbele0,
 485      >                noempo, hetmpo,
 486      >                fammpo, cfampo,
 487      >                nnosca, nmpsca, nmpsho,
 488      >                famele, noeele, typele,
 489      >                ulsort, langue, codret )
 490 c
 491         nbmapo = elemen - nbtetr - nbtria - nbsegm
 492 c
 493       endif
 494 c
 495       endif
 496 c
 497 c 3.5. ==> les elements quadrangulaires :
 498 c                                 - quadrangles actifs en 2,5d
 499 c                                 - quadrangles actifs isoles en 3d,
 500 #ifdef _DEBUG_HOMARD_
 501       write (ulsort,90002) '3.5. quadrangles ; codret', codret
 502       write (ulsort,90002) 'nbquac', nbquac
 503 #endif
 504 c
 505       if ( codret.eq.0 ) then
 506 c
 507       if ( rsquto.eq.0 ) then
 508 c
 509         nbquad = 0
 510 c
 511       else
 512 c
 513 #ifdef _DEBUG_HOMARD_
 514       write (ulsort,texte(langue,3)) 'PCMAQU', nompro
 515 #endif
 516         call pcmaqu ( elemen, nbele0,
 517      >                somare, np2are,
 518      >                arequa, hetqua, ninqua,
 519      >                famqua, cfaqua,
 520      >                nnosca, nqusca, nqusho,
 521      >                famele, noeele, typele,
 522      >                ulsort, langue, codret )
 523 c
 524         nbquad = elemen - nbtetr - nbtria - nbsegm - nbmapo
 525 c
 526       endif
 527 c
 528       endif
 529 c
 530 c 3.6. ==> les hexaedres actifs
 531 #ifdef _DEBUG_HOMARD_
 532       write (ulsort,90002) '3.6. hexaedres ; codret', codret
 533 #endif
 534 c
 535       if ( codret.eq.0 ) then
 536 c
 537       if ( rsheto.eq.0 ) then
 538 c
 539         nbhexa = 0
 540 c
 541       else
 542 c
 543 #ifdef _DEBUG_HOMARD_
 544       write (ulsort,texte(langue,3)) 'PCMAHE', nompro
 545 #endif
 546         call pcmahe ( elemen, nbele0,
 547      >                somare, np2are,
 548      >                arequa,
 549      >                quahex, coquhe, arehex,
 550      >                hethex, ninhex,
 551      >                famhex, cfahex,
 552      >                nnosca, nhesca, nhesho,
 553      >                famele, noeele, typele,
 554      >                ulsort, langue, codret )
 555 c
 556         nbhexa = elemen - nbtetr - nbtria - nbsegm - nbmapo - nbquad
 557 c
 558       endif
 559 c
 560       endif
 561 c
 562 c 3.7. ==> les pyramides actives
 563 c
 564 #ifdef _DEBUG_HOMARD_
 565       write (ulsort,90002) '3.7. pyramides ; codret', codret
 566 #endif
 567 c
 568       if ( codret.eq.0 ) then
 569 c
 570       if ( rspyto.eq.0 ) then
 571 c
 572         nbpyra = 0
 573 c
 574       else
 575 c
 576 #ifdef _DEBUG_HOMARD_
 577       write (ulsort,texte(langue,3)) 'PCMAPY', nompro
 578 #endif
 579         call pcmapy ( elemen, nbele0,
 580      >                somare, np2are,
 581      >                aretri,
 582      >                facpyr, cofapy, arepyr,
 583      >                hetpyr, fampyr, cfapyr,
 584      >                nnosca, npysca, npysho,
 585      >                famele, noeele, typele,
 586      >                ulsort, langue, codret )
 587 c
 588         nbpyra = elemen - nbtetr - nbtria - nbsegm - nbmapo - nbquad
 589      >                  - nbhexa
 590 #ifdef _DEBUG_HOMARD_
 591       write (ulsort,90002) 'Nombre de pyramides converties', nbpyra
 592 #endif
 593 c
 594       endif
 595 c
 596       endif
 597 c
 598 c 3.8. ==> les pentaedres actifs
 599 #ifdef _DEBUG_HOMARD_
 600       write (ulsort,90002) '3.8. pentaedres ; codret', codret
 601 #endif
 602 c
 603       if ( codret.eq.0 ) then
 604 c
 605       if ( rspeto.eq.0 ) then
 606 c
 607         nbpent = 0
 608 c
 609       else
 610 c
 611 #ifdef _DEBUG_HOMARD_
 612       write (ulsort,texte(langue,3)) 'PCMAPE', nompro
 613 #endif
 614         call pcmape ( elemen, nbele0,
 615      >                somare, np2are,
 616      >                arequa,
 617      >                facpen, cofape, arepen,
 618      >                hetpen, fampen, cfapen,
 619      >                nnosca, npesca, npesho,
 620      >                famele, noeele, typele,
 621      >                ulsort, langue, codret )
 622 c
 623         nbpent = elemen - nbtetr - nbtria - nbsegm - nbmapo - nbquad
 624      >                  - nbhexa - nbpyra
 625 c
 626       endif
 627 c
 628       endif
 629 c
 630 c===
 631 c 4. Les eventuelles mailles ignorees
 632 c====
 633 c
 634 #ifdef _DEBUG_HOMARD_
 635       write (ulsort,90002) '4. Elements ignores ; codret', codret
 636 #endif
 637 c
 638       if ( codret.eq.0 ) then
 639 c
 640       if ( nbelig.ne.0 ) then
 641 c
 642         nbpyra = nbpyra + nbelig
 643 #ifdef _DEBUG_HOMARD_
 644       write (ulsort,90002) 'Nombre de pyramides', nbpyra
 645 #endif
 646 c
 647 #ifdef _DEBUG_HOMARD_
 648       write (ulsort,texte(langue,3)) 'PCMAIG', nompro
 649 #endif
 650         call pcmaig ( nbele0, nbelig,
 651      >                fmdeig, noeeig,
 652      >                elemen, typele, famele, noeele,
 653      >                nnosca, ancnoe, trav1a, deraff,
 654      >                ulsort, langue, codret )
 655 c
 656       endif
 657 c
 658       endif
 659 c
 660 c====
 661 c 5. mise a jour
 662 c====
 663 c
 664 #ifdef _DEBUG_HOMARD_
 665       write (ulsort,90002) '5. mise a jour ; codret', codret
 666 #endif
 667 c
 668 c 5.1.==>  nombres caracteristiques du maillage de calcul
 669 c
 670       if ( codret.eq.0 ) then
 671 c
 672       if ( nbhexa.ne.0 ) then
 673         nbmaae = 12
 674         nbmafe = 6
 675       elseif ( nbpent.ne.0 ) then
 676         nbmaae = 9
 677         nbmafe = 5
 678       elseif ( nbpyra.ne.0 ) then
 679         nbmaae = 8
 680         nbmafe = 5
 681       elseif ( nbtetr.ne.0 ) then
 682         nbmaae = 6
 683         nbmafe = 4
 684       elseif ( nbquad.ne.0 ) then
 685         nbmaae = 4
 686         nbmafe = 1
 687       elseif ( nbtria.ne.0 ) then
 688         nbmaae = 3
 689         nbmafe = 1
 690       else
 691         nbmaae = 1
 692         nbmafe = 0
 693       endif
 694 c
 695       nbelem = nbmapo + nbsegm +
 696      >         nbtria + nbquad +
 697      >         nbtetr + nbhexa + nbpyra + nbpent
 698 c
 699       if ( elemen.ne.nbelem ) then
 700         write (ulsort,texte(langue,4)) elemen
 701         write (ulsort,texte(langue,5)) nbelem
 702         write (ulsort,texte(langue,3))
 703         codret = 1
 704       endif
 705 c
 706       numael = nbelem
 707       numano = nbnoto
 708 c
 709       nvoare = -1
 710       nvosom = -1
 711 c
 712       endif
 713 c
 714 c 5.2. ==> nombres propres a la renumerotation des entites
 715 c
 716       if ( codret.eq.0 ) then
 717 c
 718       if ( nbmapo.ne.0 ) then
 719         rsmpac = elemen
 720       else
 721         rsmpac = 0
 722       endif
 723 c
 724       if ( nbsegm.ne.0 ) then
 725         rsarac = elemen
 726       else
 727         rsarac = 0
 728       endif
 729 c
 730       if ( nbtria.ne.0 ) then
 731         rstrac = elemen
 732       else
 733         rstrac = 0
 734       endif
 735 c
 736       if ( nbquad.ne.0 ) then
 737         rsquac = elemen
 738       else
 739         rsquac = 0
 740       endif
 741 c
 742       if ( nbteto.ne.0 ) then
 743         rsteac = elemen
 744       else
 745         rsteac = 0
 746       endif
 747 c
 748       if ( nbheto.ne.0 ) then
 749         rsheac = elemen
 750       else
 751         rsheac = 0
 752       endif
 753 c
 754       if ( nbpyto.ne.0 ) then
 755         rspyac = elemen
 756       else
 757         rspyac = 0
 758       endif
 759 c
 760       if ( nbpeto.ne.0 ) then
 761         rspeac = elemen
 762       else
 763         rspeac = 0
 764       endif
 765 c
 766       rseutc = elemen
 767       if ( rsteac.eq.0 .and. rsheac.eq.0 .and. rspyac.eq.0 ) then
 768         rsevca = nbtria + nbquad
 769         rsevto = rstrto + rsquto
 770       else
 771         rsevca = nbtetr + nbhexa + nbpyra + nbpent
 772         rsevto = rsteto + rsheto + rspyto + rspeto
 773       endif
 774 c
 775       endif
 776 c
 777 c====
 778 c 6. la fin
 779 c====
 780 c
 781       if ( codret.ne.0 ) then
 782 c
 783 #include "envex2.h"
 784 c
 785       write (ulsort,texte(langue,1)) 'Sortie', nompro
 786       write (ulsort,texte(langue,2)) codret
 787 c
 788       endif
 789 c
 790 #ifdef _DEBUG_HOMARD_
 791       write (ulsort,texte(langue,1)) 'Sortie', nompro
 792       call dmflsh (iaux)
 793 #endif
 794 c
 795       end