src/tool/Creation_Maillage/cmconf.F

   1       subroutine cmconf ( nomail,
   2      >                    indnoe, indare,
   3      >                    indtri, indqua,
   4      >                    indtet, indpyr, indhex,
   5      >                    lgopti, taopti, lgopts, taopts,
   6      >                    lgetco, taetco,
   7      >                    ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c    Creation du Maillage - mise en CONFormite
  29 c    -           -                  ----
  30 c ______________________________________________________________________
  31 c
  32 c but : mise en conformite du maillage :
  33 c       - decoupage des triangles en 2
  34 c       - decoupage des quadrangles en 3 triangles,
  35 c         en 2 ou 3 quadrangles
  36 c       - decoupage des tetraedres en 2 ou en 4
  37 c       - decoupage des hexaedres en hexaedres, pyramides et tetraedres
  38 c       - decoupage des pentaedres en pyramides et tetraedres
  39 c ______________________________________________________________________
  40 c .        .     .        .                                            .
  41 c .  nom   . e/s . taille .           description                      .
  42 c .____________________________________________________________________.
  43 c . nomail . e   .  ch8   . nom de l'objet contenant le maillage       .
  44 c . indnoe . es  .   1    . indice du dernier noeud cree               .
  45 c . indare . es  .   1    . indice de la derniere arete creee          .
  46 c . indtri . es  .   1    . indice du dernier triangle cree            .
  47 c . indqua . es  .   1    . indice du dernier quadrangle cree          .
  48 c . indtet . es  .   1    . indice du dernier tetraedre cree           .
  49 c . indpyr . es  .   1    . indice de la derniere pyramide creee       .
  50 c . indhex . es  .   1    . indice du dernier hexaedre cree            .
  51 c . lgopti . e   .   1    . longueur du tableau des options entieres   .
  52 c . taopti . e   . lgopti . tableau des options                        .
  53 c . lgopts . e   .   1    . longueur du tableau des options caracteres .
  54 c . taopts . e   . lgopts . tableau des options caracteres             .
  55 c . lgetco . e   .   1    . longueur du tableau de l'etat courant      .
  56 c . taetco . e   . lgetco . tableau de l'etat courant                  .
  57 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  58 c . langue . e   .    1   . langue des messages                        .
  59 c .        .     .        . 1 : francais, 2 : anglais                  .
  60 c . codret . es  .    1   . code de retour des modules                 .
  61 c .        .     .        . 0 : pas de probleme                        .
  62 c ______________________________________________________________________
  63 c
  64 c====
  65 c 0. declarations et dimensionnement
  66 c====
  67 c
  68 c 0.1. ==> generalites
  69 c
  70       implicit none
  71       save
  72 c
  73       character*6 nompro
  74       parameter ( nompro = 'CMCONF' )
  75 c
  76 #include "nblang.h"
  77 c
  78 c 0.2. ==> communs
  79 c
  80 #include "envex1.h"
  81 c
  82 #include "gmenti.h"
  83 #include "gmreel.h"
  84 c
  85 #include "nombno.h"
  86 #include "nombtr.h"
  87 #include "nombqu.h"
  88 #include "nombte.h"
  89 #include "nombhe.h"
  90 #include "nombpe.h"
  91 #include "nombpy.h"
  92 #include "nouvnb.h"
  93 #include "envca1.h"
  94 #include "impr02.h"
  95 c
  96 c 0.3. ==> arguments
  97 c
  98       character*8 nomail
  99 c
 100       integer indnoe, indare, indtri, indqua
 101       integer indtet, indpyr, indhex
 102 c
 103       integer lgopti
 104       integer taopti(lgopti)
 105 c
 106       integer lgopts
 107       character*8 taopts(lgopts)
 108 c
 109       integer lgetco
 110       integer taetco(lgetco)
 111 c
 112       integer ulsort, langue, codret
 113 c
 114 c 0.4. ==> variables locales
 115 c
 116       integer codava
 117       integer nretap, nrsset
 118       integer iaux, jaux
 119 c
 120       integer codre0
 121       integer pdecfa
 122       integer phetno, pcoono, pareno
 123       integer phetar, psomar, pfilar, pmerar
 124       integer phettr, paretr, pfiltr, ppertr, pnivtr
 125       integer phetqu, parequ, pfilqu, pperqu, pnivqu, adnmqu
 126       integer phette, ptrite, pcotrt, pfilte, pperte, adtes2, parete
 127       integer phetpe, pfacpe, pcofap, pfilpe, pperpe, adpes2, parepe
 128       integer phetpy, pfacpy, pcofay, pfilpy, pperpy, adpys2, parepy
 129       integer pquahe, pcoquh, phethe, pfilhe, pperhe, adhes2, parehe
 130       integer pfamno, pcfano
 131       integer pfamar
 132       integer pfamtr, pcfatr
 133       integer pfamte
 134       integer pfamqu, pcfaqu
 135       integer pfamhe, pcfahe
 136       integer pfampe, pcfape
 137       integer pfampy
 138 c
 139       integer indtea, indpya, indhea
 140 c
 141       character*6 saux
 142       character*8 norenu
 143       character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
 144       character*8 nhtetr, nhhexa, nhpyra, nhpent
 145       character*8 nhelig
 146       character*8 nhvois, nhsupe, nhsups
 147       character*8 ntrav1
 148 c
 149       integer nbmess
 150       parameter ( nbmess = 10 )
 151       character*80 texte(nblang,nbmess)
 152 c
 153 c 0.5. ==> initialisations
 154 c ______________________________________________________________________
 155 c
 156 c====
 157 c 1. messages
 158 c====
 159 c
 160       codava = codret
 161 c
 162 c=======================================================================
 163       if ( codava.eq.0 ) then
 164 c=======================================================================
 165 c
 166 c 1.3. ==> les messages
 167 c
 168 #include "impr01.h"
 169 c
 170 #ifdef _DEBUG_HOMARD_
 171       write (ulsort,texte(langue,1)) 'Entree', nompro
 172       call dmflsh (iaux)
 173 #endif
 174 c
 175       texte(1,4) =
 176      > '(/,a6,'' MISE EN CONFORMITE DU MAILLAGE'')'
 177       texte(1,5) = '(37(''=''),/)'
 178       texte(1,6) =
 179      >'(5x,''Nombre de '',a,'' crees :'',i10)'
 180       texte(1,7) =
 181      > '(5x,''Ce nombre est incorrect. On en attendait'',i10)'
 182 c
 183       texte(2,4) =
 184      > '(/,a6,'' MESH CONFORMITY'')'
 185       texte(2,5) = '(22(''=''),/)'
 186       texte(2,6) = '(5x,''Number of new '',a,'':'',i10)'
 187       texte(2,7) =
 188      > '(5x,''Wrong number.'',i10,'' were expected.'')'
 189 c
 190 #include "impr03.h"
 191 c
 192 c 1.4. ==> le numero de sous-etape
 193 c
 194       nretap = taetco(1)
 195       nrsset = taetco(2) + 1
 196       taetco(2) = nrsset
 197 c
 198       call utcvne ( nretap, nrsset, saux, iaux, codret )
 199 c
 200 c 1.5. ==> le titre
 201 c
 202       write ( ulsort,texte(langue,4)) saux
 203       write ( ulsort,texte(langue,5))
 204 c
 205 #ifdef _DEBUG_HOMARD_
 206       write (ulsort,90006) 'nouvar =', nouvar, 'provar =', provar
 207       write (ulsort,90006) 'nouvtr =', nouvtr, 'provtr =', provtr
 208       write (ulsort,90006) 'nouvqu =', nouvqu, 'provqu =', provqu
 209       write (ulsort,90006) 'nouvte =', nouvte, 'provte =', provte,
 210      >                     'provtf =', provtf, 'provta =', provta
 211       write (ulsort,90006) 'nouvhe =', nouvhe, 'provhe =', provhe,
 212      >                     'provhf =', provhf, 'provha =', provha,
 213      >                     'nbheco =', nbheco
 214       write (ulsort,90006) 'nouvpe =', nouvpe, 'provpe =', provpe,
 215      >                     'nbpeco =', nbpeco
 216       write (ulsort,90006) 'nouvpy =', nouvpy, 'provpy =', provpy,
 217      >                     'provyf =', provyf, 'provya =', provya
 218 #endif
 219 c
 220 c====
 221 c 2. recuperation des pointeurs
 222 c====
 223 c
 224 c 2.1. ==> structure generale
 225 c
 226       if ( codret.eq.0 ) then
 227 c
 228 #ifdef _DEBUG_HOMARD_
 229       write (ulsort,texte(langue,3)) 'UTNOMH', nompro
 230 #endif
 231 c
 232       call utnomh ( nomail,
 233      >                sdim,   mdim,
 234      >               degre, maconf, homolo, hierar,
 235      >              rafdef, nbmane, typcca, typsfr, maextr,
 236      >              mailet,
 237      >              norenu,
 238      >              nhnoeu, nhmapo, nharet,
 239      >              nhtria, nhquad,
 240      >              nhtetr, nhhexa, nhpyra, nhpent,
 241      >              nhelig,
 242      >              nhvois, nhsupe, nhsups,
 243      >              ulsort, langue, codret)
 244 c
 245       endif
 246 c
 247 c 2.2. ==> tableaux
 248 c
 249       if ( codret.eq.0 ) then
 250 c
 251       if ( nouvno.eq.nbnoto ) then
 252         iaux = 5
 253       else
 254         iaux = 210
 255       endif
 256 #ifdef _DEBUG_HOMARD_
 257       write (ulsort,texte(langue,3)) 'UTAD01', nompro
 258 #endif
 259       call utad01 ( iaux, nhnoeu,
 260      >              phetno,
 261      >              pfamno, pcfano,   jaux,
 262      >              pcoono, pareno,   jaux,   jaux,
 263      >              ulsort, langue, codret )
 264 c
 265       iaux = 210
 266 #ifdef _DEBUG_HOMARD_
 267       write (ulsort,texte(langue,3)) 'UTAD02_ar', nompro
 268 #endif
 269       call utad02 ( iaux, nharet,
 270      >              phetar, psomar, pfilar, pmerar,
 271      >              pfamar,   jaux,   jaux,
 272      >                jaux,   jaux,   jaux,
 273      >                jaux,   jaux,   jaux,
 274      >              ulsort, langue, codret )
 275 c
 276       if ( nouvtr.ne.0 ) then
 277 c
 278         iaux = 85470
 279 #ifdef _DEBUG_HOMARD_
 280       write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 281 #endif
 282         call utad02 ( iaux, nhtria,
 283      >                phettr, paretr, pfiltr, ppertr,
 284      >                pfamtr, pcfatr,   jaux,
 285      >                pnivtr,   jaux,   jaux,
 286      >                  jaux,   jaux,   jaux,
 287      >                ulsort, langue, codret )
 288 c
 289       endif
 290 c
 291       if ( nbquto.ne.0 ) then
 292 c
 293         iaux = 85470
 294         if ( mod(mailet,3).eq.0 ) then
 295           iaux = iaux*19
 296         endif
 297 #ifdef _DEBUG_HOMARD_
 298       write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 299 #endif
 300         call utad02 ( iaux, nhquad,
 301      >                phetqu, parequ, pfilqu, pperqu,
 302      >                pfamqu, pcfaqu,   jaux,
 303      >                pnivqu,   jaux,   jaux,
 304      >                adnmqu,   jaux,   jaux,
 305      >                ulsort, langue, codret )
 306 c
 307       endif
 308 c
 309       if ( provte.ne.0 ) then
 310 c
 311         iaux = 2730
 312         if ( nbheco.ne.0 .or. nbpeco.ne.0 ) then
 313           iaux = iaux*17
 314         endif
 315         if ( taopti(30).ge.0 .and. nbteca.gt.0 ) then
 316           iaux = iaux*31
 317         endif
 318 #ifdef _DEBUG_HOMARD_
 319       write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 320 #endif
 321         call utad02 ( iaux, nhtetr,
 322      >                phette, ptrite, pfilte, pperte,
 323      >                pfamte,   jaux,   jaux,
 324      >                  jaux, pcotrt, adtes2,
 325      >                  jaux,   jaux, parete,
 326      >                ulsort, langue, codret )
 327 c
 328       endif
 329 c
 330       if ( nbheto.ne.0 ) then
 331 c
 332         iaux = 101010
 333         if ( nbheco.ne.0 ) then
 334           iaux = iaux*17
 335         endif
 336         if ( taopti(30).ge.0 .and. nbheca.gt.0 ) then
 337           iaux = iaux*31
 338         endif
 339 #ifdef _DEBUG_HOMARD_
 340       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 341 #endif
 342         call utad02 ( iaux, nhhexa,
 343      >                phethe, pquahe, pfilhe, pperhe,
 344      >                pfamhe, pcfahe,   jaux,
 345      >                  jaux, pcoquh, adhes2,
 346      >                  jaux,   jaux, parehe,
 347      >                ulsort, langue, codret )
 348 c
 349       endif
 350 c
 351       if ( nbpeto.ne.0 ) then
 352 c
 353         iaux = 101010
 354         if ( nbpeco.ne.0 ) then
 355           iaux = iaux*17
 356         endif
 357         if ( taopti(30).ge.0 .and. nbpeca.gt.0 ) then
 358           iaux = iaux*31
 359         endif
 360 #ifdef _DEBUG_HOMARD_
 361       write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 362 #endif
 363         call utad02 ( iaux, nhpent,
 364      >                phetpe, pfacpe, pfilpe, pperpe,
 365      >                pfampe, pcfape,   jaux,
 366      >                  jaux, pcofap, adpes2,
 367      >                  jaux,   jaux, parepe,
 368      >                ulsort, langue, codret )
 369 c
 370       endif
 371 c
 372       if ( provpy.ne.0 ) then
 373 c
 374         iaux = 101010
 375         if ( nbheco.ne.0 .or. nbpeco.ne.0 ) then
 376           iaux = iaux*17
 377         endif
 378         if ( taopti(30).ge.0 .and. nbpyca.gt.0 ) then
 379           iaux = iaux*31
 380         endif
 381 #ifdef _DEBUG_HOMARD_
 382       write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
 383 #endif
 384         call utad02 ( iaux, nhpyra,
 385      >                phetpy, pfacpy, pfilpy, pperpy,
 386      >                pfampy,   jaux,   jaux,
 387      >                  jaux, pcofay, adpys2,
 388      >                  jaux,   jaux, parepy,
 389      >                ulsort, langue, codret )
 390 c
 391       endif
 392 c
 393       endif
 394 c
 395       if ( codret.eq.0 ) then
 396 c
 397       ntrav1 = taopts(12)
 398       call gmadoj ( ntrav1, pdecfa, iaux, codre0 )
 399       codret = max ( abs(codre0), codret )
 400 c
 401       endif
 402 c
 403 c 2.3. ==> indice de depart des volumes decrits par aretes
 404 c
 405       if ( codret.eq.0 ) then
 406 c
 407       indtea = nouvtf
 408       indhea = nouvhf
 409       indpya = nouvyf
 410 #ifdef _DEBUG_HOMARD_
 411       write (ulsort,90002) 'indtet, indtea', indtet, indtea
 412 #endif
 413 c
 414       endif
 415 c
 416 c====
 417 c 3. decoupage des triangles en 2
 418 c====
 419 #ifdef _DEBUG_HOMARD_
 420       write (ulsort,90002) '3. triangles ; codret', codret
 421 #endif
 422 c
 423       if ( codret.eq.0 ) then
 424 c
 425       if ( nbtrto.ne.0 .and. provtr.gt.0 ) then
 426 c
 427 #ifdef _DEBUG_HOMARD_
 428         write (ulsort,texte(langue,3)) 'CMCDTR', nompro
 429 #endif
 430 c
 431         call cmcdtr ( indare, indtri, imem(pdecfa),
 432      >                imem(phetar), imem(psomar),
 433      >                imem(pfilar), imem(pmerar), imem(pfamar),
 434      >                imem(phettr), imem(paretr),
 435      >                imem(pfiltr), imem(ppertr), imem(pfamtr),
 436      >                imem(pnivtr),
 437      >                imem(pcfatr),
 438      >                ulsort, langue, codret )
 439 c
 440       endif
 441 c
 442       endif
 443 c
 444 c====
 445 c 4. decoupage des quadrangles en 3 triangles, en 2 ou 3 quadrangles
 446 c====
 447 #ifdef _DEBUG_HOMARD_
 448       write (ulsort,90002) '4. quadrangles ; codret', codret
 449 #endif
 450 c
 451       if ( codret.eq.0 ) then
 452 c
 453       if ( nbquto.ne.0 .and. ( provtr.gt.0 .or. provqu.gt.0 ) ) then
 454 c
 455 #ifdef _DEBUG_HOMARD_
 456         write (ulsort,texte(langue,3)) 'CMCDQU', nompro
 457 #endif
 458 c
 459         call cmcdqu ( indnoe, indare, indtri, indqua, imem(pdecfa),
 460      >                rmem(pcoono), imem(phetno), imem(pareno),
 461      >                imem(pfamno),
 462      >                imem(phetar), imem(psomar),
 463      >                imem(pfilar), imem(pmerar), imem(pfamar),
 464      >                imem(phettr), imem(paretr),
 465      >                imem(pfiltr), imem(ppertr), imem(pfamtr),
 466      >                imem(pnivtr),
 467      >                imem(phetqu), imem(parequ),
 468      >                imem(pfilqu), imem(pperqu), imem(pfamqu),
 469      >                imem(pnivqu), imem(adnmqu),
 470      >                imem(pcfaqu),
 471      >                ulsort, langue, codret )
 472 c
 473       endif
 474 c
 475       endif
 476 c
 477 c====
 478 c 5. decoupage des tetraedres en 2 ou 4 tetraedres
 479 c====
 480 #ifdef _DEBUG_HOMARD_
 481       write (ulsort,90002) '5. tetraedres ; codret', codret
 482 #endif
 483 c
 484       if ( codret.eq.0 ) then
 485 c
 486       if ( nbteto.ne.0 .and. provte.gt.0 ) then
 487 c
 488 #ifdef _DEBUG_HOMARD_
 489         write (ulsort,texte(langue,3)) 'CMCDTE', nompro
 490 #endif
 491 c
 492         call cmcdte ( indare, indtri, indtet,
 493      >                imem(phetar), imem(psomar),
 494      >                imem(pfilar), imem(pmerar), imem(pfamar),
 495      >                imem(phettr), imem(paretr),
 496      >                imem(pfiltr), imem(ppertr), imem(pfamtr),
 497      >                imem(pnivtr),
 498      >                imem(phette), imem(ptrite), imem(pcotrt),
 499      >                imem(pfilte), imem(pperte), imem(pfamte),
 500      >                ulsort, langue, codret )
 501 c
 502       endif
 503 c
 504       endif
 505 c
 506 c====
 507 c 6. decoupage des hexaedres en pyramides, tetraedres, hexaedres
 508 c====
 509 #ifdef _DEBUG_HOMARD_
 510       write (ulsort,90002) '6. hexaedres ; codret', codret
 511 #endif
 512 c
 513       if ( codret.eq.0 ) then
 514 c
 515       if ( nbheto.ne.0 .and.
 516      > ( provte.gt.0 .or. provpy.gt.0 .or. provhe.gt.0 ) ) then
 517 c
 518 c 6.1. ==> conforme, avec des boites pour les hexaedres
 519 c
 520         if ( taopti(30).eq.-1 ) then
 521 #ifdef _DEBUG_HOMARD_
 522       write (ulsort,*) 'conforme, avec des boites pour les hexaedres'
 523 #endif
 524 #ifdef _DEBUG_HOMARD_
 525           write (ulsort,texte(langue,3)) 'CMCDHB', nompro
 526 #endif
 527 c
 528           call cmcdhb ( indnoe, indare, indtri, indtet, indpyr,
 529      >                  rmem(pcoono), imem(phetno), imem(pareno),
 530      >                  imem(pfamno),
 531      >                  imem(phetar), imem(psomar),
 532      >                  imem(pfilar), imem(pmerar), imem(pfamar),
 533      >                  imem(phettr), imem(paretr),
 534      >                  imem(pfiltr), imem(ppertr), imem(pfamtr),
 535      >                  imem(pnivtr),
 536      >                  imem(phetqu), imem(parequ),
 537      >                  imem(pfilqu),
 538      >                  imem(phette), imem(ptrite), imem(pcotrt),
 539      >                  imem(pfilte), imem(pperte), imem(pfamte),
 540      >                  imem(adtes2),
 541      >                  imem(phetpy), imem(pfacpy), imem(pcofay),
 542      >                  imem(pfilpy), imem(pperpy), imem(pfampy),
 543      >                  imem(adpys2),
 544      >                  imem(pquahe), imem(pcoquh), imem(phethe),
 545      >                  imem(pfilhe), imem(adhes2),
 546      >                  imem(pfamhe), imem(pcfahe),
 547      >                  ulsort, langue, codret )
 548 c
 549 c 6.2. ==> conforme general
 550 c
 551         else
 552 #ifdef _DEBUG_HOMARD_
 553       write (ulsort,*) nompro, ' - conforme'
 554 #endif
 555 #ifdef _DEBUG_HOMARD_
 556           write (ulsort,texte(langue,3)) 'CMCDHE', nompro
 557 #endif
 558 c
 559           call cmcdhe ( indnoe, indare, indtea, indpya, indhea,
 560      >                  rmem(pcoono), imem(phetno), imem(pareno),
 561      >                  imem(pfamno),
 562      >                  imem(phetar), imem(psomar),
 563      >                  imem(pfilar), imem(pmerar), imem(pfamar),
 564      >                  imem(paretr),
 565      >                  imem(parequ),
 566      >                  imem(pfilqu),
 567      >                  imem(phette), imem(parete),
 568      >                  imem(pfilte), imem(pperte), imem(pfamte),
 569      >                  imem(adtes2),
 570      >                  imem(phetpy), imem(parepy),
 571      >                  imem(pfilpy), imem(pperpy), imem(pfampy),
 572      >                  imem(adpys2),
 573      >                  imem(phethe), imem(parehe),
 574      >                  imem(pfilhe), imem(adhes2), imem(pperhe),
 575      >                  imem(pfamhe), imem(pcfahe),
 576      >                  imem(pquahe), imem(pcoquh),
 577      >                  ulsort, langue, codret )
 578 c
 579         endif
 580 c
 581       endif
 582 c
 583       endif
 584 cgn      call gmprsx (nompro,nhhexa//'.ConnDesc')
 585 cgn      call gmprsx (nompro,nhhexa//'.ConnAret')
 586 cgn      call gmprsx (nompro,nhhexa//'.InfoSupp')
 587 cgn      call gmprsx (nompro,nhpyra//'.ConnAret')
 588 cgn      call gmprsx (nompro,nhpyra//'.ConnDesc')
 589 cgn      call gmprsx (nompro,nhpyra//'.InfoSup2')
 590 cgn      call gmprsx (nompro,nhhexa//'.InfoSup2')
 591 cgn      call gmprsx (nompro,nhvois)
 592 cgn      call gmprsx (nompro,nhvois//'.Vol/Tri')
 593 cgn      call gmprsx (nompro,nhvois//'.Vol/Qua')
 594 cgn      call gmprsx (nompro,nhvois//'.PyPe/Tri')
 595 cgn      call gmprsx (nompro,nhvois//'.PyPe/Qua')
 596 c
 597 c====
 598 c 7. decoupage des pentaedres en pyramides et tetraedres
 599 c====
 600 #ifdef _DEBUG_HOMARD_
 601       write (ulsort,90002) '7. pentaedres ; codret', codret
 602 #endif
 603 c
 604       if ( codret.eq.0 ) then
 605 c
 606       if ( nbpeto.ne.0 .and. ( provte.gt.0 .or. provpy.gt.0 ) ) then
 607 c
 608 #ifdef _DEBUG_HOMARD_
 609         write (ulsort,texte(langue,3)) 'CMCDPE', nompro
 610 #endif
 611 c
 612         call cmcdpe ( indnoe, indare, indtri, indtet, indpyr,
 613      >                rmem(pcoono), imem(phetno), imem(pareno),
 614      >                imem(pfamno),
 615      >                imem(phetar), imem(psomar),
 616      >                imem(pfilar), imem(pmerar), imem(pfamar),
 617      >                imem(phettr), imem(paretr),
 618      >                imem(pfiltr), imem(ppertr), imem(pfamtr),
 619      >                imem(pnivtr),
 620      >                imem(phetqu), imem(parequ),
 621      >                imem(pfilqu),
 622      >                imem(phette), imem(ptrite), imem(pcotrt),
 623      >                imem(pfilte), imem(pperte), imem(pfamte),
 624      >                imem(adtes2),
 625      >                imem(phetpy), imem(pfacpy), imem(pcofay),
 626      >                imem(pfilpy), imem(pperpy), imem(pfampy),
 627      >                imem(adpys2),
 628      >                imem(pfacpe), imem(pcofap), imem(phetpe),
 629      >                imem(pfilpe), imem(adpes2),
 630      >                imem(pfampe), imem(pcfape),
 631      >                ulsort, langue, codret )
 632 c
 633       endif
 634 c
 635       endif
 636 cgn      call gmprsx (nompro,nhpyra//'.ConnDesc')
 637 cgn      call gmprsx (nompro,nhhexa//'.InfoSup2')
 638 cgn      call gmprsx (nompro,nhvois)
 639 cgn      call gmprsx (nompro,nhvois//'.Vol/Tri')
 640 cgn      call gmprsx (nompro,nhvois//'.Vol/Qua')
 641 cgn      call gmprsx (nompro,nhvois//'.PyPe/Tri')
 642 cgn      call gmprsx (nompro,nhvois//'.PyPe/Qua')
 643 c
 644 c====
 645 c 8. verifications des nombres d'entites crees et impressions
 646 c====
 647 #ifdef _DEBUG_HOMARD_
 648       write (ulsort,90002) '8. verifications ; codret', codret
 649 #endif
 650 c
 651       if ( codret.eq.0 ) then
 652 c
 653       indtet = indtea
 654       indhex = indhea
 655       indpyr = indpya
 656 c
 657       iaux = 0
 658 c
 659 c  attention : on ne sait pas verifier avec des noeuds P2
 660 c
 661       if ( degre.eq.1 ) then
 662       if ( provp1.ne.0 ) then
 663         write (ulsort,texte(langue,6)) mess14(langue,3,-1),
 664      >                                 indnoe-permno
 665         if ( indnoe.ne.nouvno ) then
 666           write (ulsort,texte(langue,7)) provp1
 667           iaux = iaux + 1
 668         endif
 669       endif
 670       endif
 671 c
 672       if ( provar.ne.0 ) then
 673         write (ulsort,texte(langue,6)) mess14(langue,3,1),
 674      >                                 indare-permar
 675         if ( indare.ne.nouvar ) then
 676           write (ulsort,texte(langue,7)) provar
 677           iaux = iaux + 1
 678         endif
 679       endif
 680 c
 681       if ( provtr.ne.0 ) then
 682         write (ulsort,texte(langue,6)) mess14(langue,3,2),
 683      >                                 indtri-permtr
 684         if ( indtri.ne.nouvtr ) then
 685           write (ulsort,texte(langue,7)) provtr
 686           iaux = iaux + 1
 687         endif
 688       endif
 689 c
 690       if ( provqu.ne.0 ) then
 691         write (ulsort,texte(langue,6)) mess14(langue,3,4),
 692      >                                 indqua-permqu
 693         if ( indqua.ne.nouvqu ) then
 694           write (ulsort,texte(langue,7)) provqu
 695           iaux = iaux + 1
 696         endif
 697       endif
 698 c
 699       if ( provte.ne.0 ) then
 700         write (ulsort,texte(langue,6)) mess14(langue,3,3),
 701      >                                 indtet-permte
 702         if ( indtet.ne.nouvte ) then
 703           write (ulsort,texte(langue,7)) provte
 704           iaux = iaux + 1
 705         endif
 706       endif
 707 c
 708       if ( provpy.ne.0 ) then
 709         write (ulsort,texte(langue,6)) mess14(langue,3,5),
 710      >                                 indpyr-permpy
 711         if ( indpyr.ne.nouvpy ) then
 712           write (ulsort,texte(langue,7)) provpy
 713           iaux = iaux + 1
 714         endif
 715       endif
 716 c
 717       if ( iaux.gt.0 ) then
 718         codret = 4
 719       endif
 720 c
 721       endif
 722 c
 723 c====
 724 c 9. la fin
 725 c====
 726 c
 727       if ( codret.ne.0 ) then
 728 c
 729 #include "envex2.h"
 730 c
 731       write (ulsort,texte(langue,1)) 'Sortie', nompro
 732       write (ulsort,texte(langue,2)) codret
 733 c
 734       endif
 735 c
 736 #ifdef _DEBUG_HOMARD_
 737       write (ulsort,texte(langue,1)) 'Sortie', nompro
 738       call dmflsh (iaux)
 739 #endif
 740 c
 741 c=======================================================================
 742       endif
 743 c=======================================================================
 744 c
 745       end