src/tool/Utilitaire/utvgvf.F

   1       subroutine utvgvf ( nhvois, nhtria, nhquad,
   2      >                    nhtetr, nhhexa, nhpyra, nhpent,
   3      >                    option,
   4      >                    ulsort, langue, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c    UTilitaire - VoisinaGe Volumes-Face
  26 c    --           -      -  -       -
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nhvois . e   . char8  . nom de l'objet voisinage                   .
  32 c . nhtria . e   . char8  . nom de l'objet decrivant les triangles     .
  33 c . nhquad . e   . char8  . nom de l'objet decrivant les quadrangles   .
  34 c . nhtetr . e   . char8  . nom de l'objet decrivant les tetraedres    .
  35 c . nhhexa . e   . char8  . nom de l'objet decrivant les hexaedres     .
  36 c . nhpyra . e   . char8  . nom de l'objet decrivant les pyramides     .
  37 c . nhpent . e   . char8  . nom de l'objet decrivant les pentaedres    .
  38 c . option . e   .   1    . pilotage des volumes voisins des faces :   .
  39 c .        .     .        . -1 : on detruit la table.                  .
  40 c .        .     .        . 0 : on ne fait rien.                       .
  41 c .        .     .        . 1 : on construit la table.                 .
  42 c .        .     .        . 2 : on construit la table et on controle   .
  43 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  44 c . langue . e   .    1   . langue des messages                        .
  45 c .        .     .        . 1 : francais, 2 : anglais                  .
  46 c . codret . es  .    1   . code de retour des modules                 .
  47 c .        .     .        . 0 : pas de probleme                        .
  48 c .        .     .        . 1 : probleme                               .
  49 c ______________________________________________________________________
  50 c
  51 c====
  52 c 0. declarations et dimensionnement
  53 c====
  54 c
  55 c 0.1. ==> generalites
  56 c
  57       implicit none
  58       save
  59 c
  60       character*6 nompro
  61       parameter ( nompro = 'UTVGVF' )
  62 c
  63 #include "nblang.h"
  64 c
  65 c 0.2. ==> communs
  66 c
  67 #include "envex1.h"
  68 c
  69 #include "gmenti.h"
  70 #include "impr02.h"
  71 c
  72 c 0.3. ==> arguments
  73 c
  74       character*8 nhvois, nhtria, nhquad
  75       character*8 nhtetr, nhhexa, nhpyra, nhpent
  76 c
  77       integer option
  78 c
  79       integer ulsort, langue, codret
  80 c
  81 c 0.4. ==> variables locales
  82 c
  83       integer iaux, jaux, kaux
  84       integer nbfac(2)
  85       integer codre0
  86       integer codre1, codre2, codre3, codre4
  87 c
  88       integer nbtrto, nbquto
  89       integer nbteto, nbheto, nbpyto, nbpeto
  90       integer nbteca, nbheca, nbpyca, nbpeca
  91       integer nbtecf, nbhecf, nbpycf, nbpecf
  92       integer ptrite, phette, parete, pfilte
  93       integer pquahe, phethe, parehe, pfilhe, adhes2
  94       integer pfacpy, phetpy, parepy, pfilpy
  95       integer pfacpe, phetpe, parepe, pfilpe, adpes2
  96       integer advotq, advotr, advoqu
  97       integer lgpptq, adpptq
  98       integer lgpptr, adpptr, nupptr
  99       integer lgppqu, adppqu, nuppqu
 100 c
 101       character*9 suff(4)
 102 c
 103       integer nbmess
 104       parameter ( nbmess = 10 )
 105       character*80 texte(nblang,nbmess)
 106 c
 107 c 0.5. ==> initialisations
 108 c ______________________________________________________________________
 109 c
 110 c====
 111 c 1. initialisations
 112 c====
 113 c
 114 #include "impr01.h"
 115 c
 116 #ifdef _DEBUG_HOMARD_
 117       write (ulsort,texte(langue,1)) 'Entree', nompro
 118       call dmflsh (iaux)
 119 #endif
 120 c
 121 c 1.1. ==> messages
 122 c
 123       texte(1,4) = '(''Voisinage volumes-faces.'')'
 124       texte(1,5) = '(''Demande : '',i6)'
 125       texte(1,6) = '(''Mauvaise demande.'')'
 126       texte(1,7) = '(''Nombre de '',a,'' : '',i10)'
 127       texte(1,8) = '(''Voisinage '',a,''/ '',a)'
 128 c
 129       texte(2,4) = '(''Neighbourhood volumes-faces.'')'
 130       texte(2,5) = '(''Request : '',i6)'
 131       texte(2,6) = '(''Bad request.'')'
 132       texte(2,7) = '(''Number of '',a,'' : '',i10)'
 133       texte(2,8) = '(''Neighbourhood '',a,''/ '',a)'
 134 c
 135 #include "impr03.h"
 136 c
 137 #ifdef _DEBUG_HOMARD_
 138       write (ulsort,texte(langue,4))
 139       write (ulsort,texte(langue,5)) option
 140 #endif
 141 c
 142 c 1.2. ==> initialisations
 143 c
 144       suff(1) = '.Vol/Tri'
 145       suff(2) = '.Vol/Qua'
 146       suff(3) = '.PyPe/Tri'
 147       suff(4) = '.PyPe/Qua'
 148 c
 149       codret = 0
 150 c
 151 c====
 152 c 2. Controle de l'option
 153 c====
 154 c
 155 #ifdef _DEBUG_HOMARD_
 156       write (ulsort,90002) '2. Controle option ; codret', codret
 157 #endif
 158       if ( codret.eq.0 ) then
 159 c
 160       if ( option.lt.-1 .or. option.gt.2 ) then
 161 c
 162         write (ulsort,texte(langue,5)) option
 163         write (ulsort,texte(langue,6))
 164         codret = 2
 165 c
 166       endif
 167 c
 168       endif
 169 c
 170 c====
 171 c 3. recuperation des donnees du maillage d'entree
 172 c    remarque : on relit les nombres d'entites car les communs ne
 173 c               sont pas forcement remplis
 174 c====
 175 #ifdef _DEBUG_HOMARD_
 176       write (ulsort,90002) '3. recuperation ; codret', codret
 177 #endif
 178 c
 179       if ( option.eq.1 .or. option.eq.2 ) then
 180 c
 181 c 3.1. ==> nombre d'entites volumiques
 182 c
 183         if ( codret.eq.0 ) then
 184 c
 185         call gmliat ( nhtetr, 1, nbteto, codre1 )
 186         call gmliat ( nhpyra, 1, nbpyto, codre2 )
 187         call gmliat ( nhhexa, 1, nbheto, codre3 )
 188         call gmliat ( nhpent, 1, nbpeto, codre4 )
 189 c
 190         codre0 = min ( codre1, codre2, codre3, codre4 )
 191         codret = max ( abs(codre0), codret,
 192      >                 codre1, codre2, codre3, codre4 )
 193 c
 194         call gmliat ( nhtetr, 2, nbteca, codre1 )
 195         call gmliat ( nhpyra, 2, nbpyca, codre2 )
 196         call gmliat ( nhhexa, 2, nbheca, codre3 )
 197         call gmliat ( nhpent, 2, nbpeca, codre4 )
 198 c
 199         codre0 = min ( codre1, codre2, codre3, codre4 )
 200         codret = max ( abs(codre0), codret,
 201      >                 codre1, codre2, codre3, codre4 )
 202 c
 203         nbtecf = nbteto - nbteca
 204         nbpycf = nbpyto - nbpyca
 205         nbhecf = nbheto - nbheca
 206         nbpecf = nbpeto - nbpeca
 207 c
 208         endif
 209 c
 210 #ifdef _DEBUG_HOMARD_
 211       write (ulsort,texte(langue,7)) mess14(langue,3,3), nbteto
 212       write (ulsort,texte(langue,7)) mess14(langue,3,5), nbpyto
 213       write (ulsort,texte(langue,7)) mess14(langue,3,6), nbheto
 214       write (ulsort,texte(langue,7)) mess14(langue,3,7), nbpeto
 215 #endif
 216 c
 217 c 3.2. ==> nombre de triangles/quadrangles
 218 c
 219 #ifdef _DEBUG_HOMARD_
 220       write (ulsort,90002) 'Etape 2.2 ; codret', codret
 221 #endif
 222 c
 223         if ( codret.eq.0 ) then
 224 c
 225         call gmliat ( nhtria, 1, nbtrto, codre1 )
 226         call gmliat ( nhquad, 1, nbquto, codre2 )
 227 c
 228         codre0 = min ( codre1, codre2 )
 229         codret = max ( abs(codre0), codret,
 230      >                 codre1, codre2 )
 231 c
 232         endif
 233 c
 234 #ifdef _DEBUG_HOMARD_
 235       write (ulsort,texte(langue,7)) mess14(langue,3,2), nbtrto
 236       write (ulsort,texte(langue,7)) mess14(langue,3,4), nbquto
 237 #endif
 238 c
 239 c 3.3. ==> adresses liees aux volumes
 240 c
 241 #ifdef _DEBUG_HOMARD_
 242       write (ulsort,90002) 'Etape 2.3 ; codret', codret
 243 #endif
 244 c
 245         if ( nbteto.ne.0 ) then
 246 c
 247           if ( codret.eq.0 ) then
 248 c
 249           iaux = 6
 250           if ( nbteca.gt.0 ) then
 251             iaux = iaux*31
 252           endif
 253 #ifdef _DEBUG_HOMARD_
 254         write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 255 #endif
 256           call utad02 (   iaux, nhtetr,
 257      >                  phette, ptrite, pfilte, jaux,
 258      >                    jaux,   jaux,   jaux,
 259      >                    jaux,   jaux,   jaux,
 260      >                    jaux,   jaux, parete,
 261      >                  ulsort, langue, codret )
 262 c
 263           endif
 264 c
 265         endif
 266 c
 267         if ( nbpyto.ne.0 ) then
 268 c
 269           if ( codret.eq.0 ) then
 270 c
 271 ccc      call gmprsx ('nhpyra dans '//nompro,nhpyra)
 272           iaux = 6
 273           if ( nbpyca.gt.0 ) then
 274             iaux = iaux*31
 275           endif
 276 #ifdef _DEBUG_HOMARD_
 277       write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
 278 #endif
 279           call utad02 (   iaux, nhpyra,
 280      >                  phetpy, pfacpy, pfilpy, jaux,
 281      >                    jaux,   jaux,   jaux,
 282      >                    jaux,   jaux,   jaux,
 283      >                    jaux,   jaux, parepy,
 284      >                  ulsort, langue, codret )
 285 c
 286           endif
 287 c
 288         endif
 289 c
 290         if ( nbheto.ne.0 ) then
 291 c
 292           if ( codret.eq.0 ) then
 293 c
 294 cgn          call gmprsx ('nhhexa dans '//nompro,nhhexa)
 295           iaux = 6
 296           if ( nbheca.gt.0 ) then
 297             iaux = iaux*31
 298           endif
 299           if ( nbpyto.ne.0 ) then
 300             call gmobal ( nhhexa//'.InfoSup2', codre1 )
 301             if ( codre1.eq.2 ) then
 302               iaux = iaux*17
 303             elseif ( codre1.ne.0 ) then
 304               codret = 2
 305             endif
 306           endif
 307 c
 308           endif
 309 c
 310           if ( codret.eq.0 ) then
 311 c
 312 #ifdef _DEBUG_HOMARD_
 313       write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 314 #endif
 315           call utad02 (   iaux, nhhexa,
 316      >                  phethe, pquahe, pfilhe, jaux,
 317      >                    jaux,   jaux,   jaux,
 318      >                    jaux,   jaux, adhes2,
 319      >                    jaux,   jaux, parehe,
 320      >                  ulsort, langue, codret )
 321 c
 322           endif
 323 c
 324         endif
 325 c
 326         if ( nbpeto.ne.0 ) then
 327 c
 328           if ( codret.eq.0 ) then
 329 c
 330 cgn          call gmprsx ('nhpent dans '//nompro,nhpent)
 331           iaux = 6
 332           if ( nbpeca.gt.0 ) then
 333             iaux = iaux*31
 334           endif
 335           if ( nbpyto.ne.0 ) then
 336             call gmobal ( nhpent//'.InfoSup2', codre1 )
 337             if ( codre1.eq.2 ) then
 338               iaux = iaux*17
 339             elseif ( codre1.ne.0 ) then
 340               codret = 2
 341             endif
 342           endif
 343 c
 344           endif
 345 c
 346           if ( codret.eq.0 ) then
 347 c
 348 #ifdef _DEBUG_HOMARD_
 349       write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 350 #endif
 351           call utad02 (   iaux, nhpent,
 352      >                  phetpe, pfacpe, pfilpe, jaux,
 353      >                    jaux,   jaux,   jaux,
 354      >                    jaux,   jaux, adpes2,
 355      >                    jaux,   jaux, parepe,
 356      >                  ulsort, langue, codret )
 357 c
 358           endif
 359 c
 360         endif
 361 c
 362       endif
 363 c
 364 c====
 365 c 4. Si on cree ou si on detruit, on commence par supprimer le graphe
 366 c====
 367 c
 368 #ifdef _DEBUG_HOMARD_
 369       write (ulsort,90002) '4. suppression ; codret', codret
 370 #endif
 371 c
 372       if ( option.eq.-1 .or. option.eq.1 .or. option.eq.2 ) then
 373 c
 374 c 4.1. ==> Destruction des anciennes structures
 375 c
 376         do 41 , iaux = 1 , 4
 377 c
 378 #ifdef _DEBUG_HOMARD_
 379         write (ulsort,*) 'Destruction eventuelle de ',suff(iaux)
 380 #endif
 381           if ( codret.eq.0 ) then
 382 c
 383           call gmobal ( nhvois//suff(iaux), codre1 )
 384 c
 385           if ( codre1.eq.0 ) then
 386             codret = 0
 387 c
 388           elseif ( codre1.eq.1 ) then
 389             call gmsgoj ( nhvois//suff(iaux), codret )
 390 c
 391           elseif ( codre1.eq.2 ) then
 392             call gmlboj ( nhvois//suff(iaux), codret )
 393 c
 394           else
 395             codret = 2
 396 c
 397           endif
 398 c
 399           endif
 400 c
 401  41     continue
 402 c
 403 c 4.2. ==> Attributs
 404 c
 405         if ( codret.eq.0 ) then
 406 c
 407         iaux = 0
 408         call gmecat ( nhvois , 1, iaux, codre1 )
 409         call gmecat ( nhvois , 2, iaux, codre2 )
 410 c
 411         codre0 = min ( codre1, codre2 )
 412         codret = max ( abs(codre0), codret,
 413      >                 codre1, codre2 )
 414 c
 415         endif
 416 c
 417       endif
 418 c
 419 c====
 420 c 5. Allocation des voisinages Vol/Tri et Vol/Qua
 421 c====
 422 c
 423 #ifdef _DEBUG_HOMARD_
 424       write (ulsort,90002) 'Etape 5 ; codret', codret
 425 #endif
 426 c
 427       if ( option.eq.1 .or. option.eq.2 ) then
 428 c
 429         nbfac(1) = nbtrto
 430         nbfac(2) = nbquto
 431 c
 432         do 50 , iaux = 1 , 2
 433 c
 434 #ifdef _DEBUG_HOMARD_
 435           write (ulsort,*) 'Creation de ',suff(iaux)
 436 #endif
 437 c
 438 c 5.1. ==> Allocation de la structure
 439 c
 440           if ( codret.eq.0 ) then
 441 c
 442           jaux = 2*nbfac(iaux)
 443           call gmaloj ( nhvois//suff(iaux) , ' ',
 444      >                  jaux, advotq, codret )
 445 c
 446           if ( iaux.eq.1 ) then
 447             advotr = advotq
 448           else
 449             advoqu = advotq
 450           endif
 451 c
 452           endif
 453 c
 454 c 5.2. ==> A priori aucun voisin
 455 c
 456           if ( codret.eq.0 ) then
 457 c
 458           kaux = advotq + jaux - 1
 459           do 52 , jaux = advotq , kaux
 460             imem(jaux) = 0
 461    52     continue
 462 c
 463           endif
 464 c
 465   50    continue
 466 c
 467       endif
 468 c
 469 c====
 470 c 6. Allocation des voisinages PyPe/Tri et PyPe/Qua
 471 c====
 472 c
 473 #ifdef _DEBUG_HOMARD_
 474       write (ulsort,90002) 'Etape 6 ; codret', codret
 475 #endif
 476 c
 477       if ( option.eq.1 .or. option.eq.2 ) then
 478 c
 479         do 60 , iaux = 1 , 2
 480 c
 481 #ifdef _DEBUG_HOMARD_
 482           write (ulsort,*) 'Creation de ',suff(iaux+2)
 483 #endif
 484 c
 485 c 6.1. ==> Allocation de la structure
 486 c
 487           if ( codret.eq.0 ) then
 488 c
 489           if ( iaux.eq.1 ) then
 490             lgpptq = 4*nbpyto + 2*nbpeto
 491           else
 492             lgpptq = nbpyto + 3*nbpeto
 493           endif
 494           jaux = 2*lgpptq
 495           call gmecat ( nhvois , 1, jaux, codre1 )
 496           call gmaloj ( nhvois//suff(iaux+2), ' ',
 497      >                  jaux, adpptq, codre2 )
 498 c
 499           codre0 = min ( codre1, codre2 )
 500           codret = max ( abs(codre0), codret,
 501      >                   codre1, codre2 )
 502 c
 503           if ( iaux.eq.1 ) then
 504             adpptr = adpptq
 505             lgpptr = lgpptq
 506           else
 507             adppqu = adpptq
 508             lgppqu = lgpptq
 509           endif
 510 c
 511           endif
 512 c
 513 c 6.2. ==> A priori aucun voisin
 514 c
 515           if ( codret.eq.0 ) then
 516 c
 517           kaux = adpptq + jaux - 1
 518           do 62 , jaux = adpptq , kaux
 519             imem(jaux) = 0
 520    62     continue
 521 c
 522           endif
 523 c
 524    60   continue
 525 c
 526       endif
 527 c
 528 c====
 529 c 7. Creation des voisinages Tet/Tri et Hex/Qua
 530 c====
 531 c
 532 #ifdef _DEBUG_HOMARD_
 533       write (ulsort,90002) 'Etape 7 ; codret', codret
 534 #endif
 535 c
 536       if ( option.eq.1 .or. option.eq.2 ) then
 537 c
 538 c 7.1. ==> determination des tetraedres voisins des triangles
 539 c
 540         if ( nbteto.ne.0 ) then
 541 c
 542           if ( codret.eq.0 ) then
 543 c
 544 #ifdef _DEBUG_HOMARD_
 545           write (ulsort,texte(langue,8)) mess14(langue,3,2),
 546      >                                   mess14(langue,3,3)
 547           write (ulsort,*) 'Creation de ',suff(1)
 548 #endif
 549 c
 550 #ifdef _DEBUG_HOMARD_
 551       write (ulsort,texte(langue,3)) 'UTTETR', nompro
 552 #endif
 553           call uttetr ( option,
 554      >                  nbtrto, nbteto, nbtecf,
 555      >                  imem(ptrite), imem(phette), imem(pfilte),
 556      >                  imem(advotr),
 557      >                  ulsort, langue, codret )
 558 c
 559 #ifdef _DEBUG_HOMARD_
 560 cgn          call gmprsx (nompro,nhvois//suff(1))
 561 cgn       call gmprot (nompro, nhvois//suff(1), 1, nbtrto*2 )
 562        call gmprot (nompro, nhvois//suff(1), 1, min(10,nbtrto*2) )
 563 #endif
 564 c
 565           endif
 566 c
 567         endif
 568 c
 569 c 7.2. ==> determination des hexaedres voisins des quadrangles
 570 c
 571         if ( nbheto.ne.0 ) then
 572 c
 573           if ( codret.eq.0 ) then
 574 c
 575 #ifdef _DEBUG_HOMARD_
 576           write (ulsort,texte(langue,8)) mess14(langue,3,4),
 577      >                                   mess14(langue,3,6)
 578           write (ulsort,*) 'Creation de ',suff(2)
 579 #endif
 580 c
 581 #ifdef _DEBUG_HOMARD_
 582       write (ulsort,texte(langue,3)) 'UTHEQU', nompro
 583 #endif
 584           call uthequ ( option,
 585      >                  nbquto, nbheto, nbhecf, nbpyto, nbpycf,
 586      >                  imem(pquahe), imem(phethe), imem(pfilhe),
 587      >                  imem(adhes2),
 588      >                  imem(pfacpy),
 589      >                  imem(advoqu),
 590      >                  ulsort, langue, codret )
 591 c
 592 #ifdef _DEBUG_HOMARD_
 593 cgn          call gmprsx (nompro, nhvois//suff(2) )
 594 cgn          call gmprot (nompro, nhvois//suff(2), 1, nbquto*2 )
 595           call gmprot (nompro, nhvois//suff(2), 1, min(20,nbquto*2) )
 596 #endif
 597 c
 598           endif
 599 c
 600         endif
 601 c
 602       endif
 603 c
 604 c====
 605 c 8. Creation des voisinages PyPe/Tri et PyPe/Qua
 606 c====
 607 c
 608 #ifdef _DEBUG_HOMARD_
 609       write (ulsort,90002) 'Etape 8 ; codret', codret
 610       write (ulsort,90002) 'nbpyto', nbpyto
 611       write (ulsort,90002) 'nbpyca', nbpyca
 612       write (ulsort,90002) 'nbpeto', nbpeto
 613       write (ulsort,90002) 'nbpeca', nbpeca
 614 #endif
 615 c
 616       nupptr = 0
 617       nuppqu = 0
 618 c
 619       if ( option.eq.1 .or. option.eq.2 ) then
 620 c
 621 c 8.1. ==> Determination des pyramides voisines
 622 c
 623         if ( nbpyto.ne.0 ) then
 624 c
 625 c 8.1.1. ==> Determination des pyramides voisines des triangles
 626 c
 627           if ( codret.eq.0 ) then
 628 #ifdef _DEBUG_HOMARD_
 629           write (ulsort,texte(langue,8)) mess14(langue,3,2),
 630      >                                   mess14(langue,3,5)
 631 #endif
 632 c
 633           iaux = 5
 634           jaux = 2
 635 #ifdef _DEBUG_HOMARD_
 636       write (ulsort,texte(langue,3)) 'UTPPQT-PY_TR', nompro
 637 #endif
 638           call utppqt ( option, nbtrto, nbpyto, nbpycf,
 639      >                  iaux, jaux,
 640      >                  imem(pfacpy), imem(phetpy),
 641      >                  imem(advotr), lgpptr, imem(adpptr), nupptr,
 642      >                  ulsort, langue, codret )
 643 c
 644           endif
 645 #ifdef _DEBUG_HOMARD_
 646 cgn      call gmprsx (nompro,'MaVo000h.Vol/Qua')
 647 cgn      call gmprsx (nompro,'MaVo000h.Vol/Qua', 1, 30)
 648 cc      call gmprsx (nompro,nhvois//'.PyPe/Qua')
 649 #endif
 650 c
 651 c 8.1.2. ==> Determination des pyramides voisines des quadrangles
 652 c
 653           if ( codret.eq.0 ) then
 654 #ifdef _DEBUG_HOMARD_
 655           write (ulsort,texte(langue,8)) mess14(langue,3,4),
 656      >                                   mess14(langue,3,5)
 657 #endif
 658 c
 659           iaux = 5
 660           jaux = 4
 661 #ifdef _DEBUG_HOMARD_
 662       write (ulsort,texte(langue,3)) 'UTPPQT-PY_QU', nompro
 663 #endif
 664           call utppqt ( option, nbquto, nbpyto, nbpycf,
 665      >                  iaux, jaux,
 666      >                  imem(pfacpy), imem(phetpy),
 667      >                  imem(advoqu), lgppqu, imem(adppqu), nuppqu,
 668      >                  ulsort, langue, codret )
 669 c
 670           endif
 671 #ifdef _DEBUG_HOMARD_
 672 cgn      call gmprsx (nompro,nhvois//'.Vol/Qua')
 673       call gmprot (nompro,nhvois//'.Vol/Qua', 1, 30)
 674 cgn      call gmprsx (nompro,nhvois//'.PyPe/Qua')
 675       call gmprot (nompro,nhvois//'.PyPe/Qua', 1, 30)
 676 #endif
 677 c
 678         endif
 679 c
 680 c 8.2. ==> Determination des pentaedres voisins
 681 c
 682         if ( nbpeto.ne.0 ) then
 683 c
 684 c 8.2.1. ==> Determination des pentaedres voisins des triangles
 685 c
 686           if ( codret.eq.0 ) then
 687 #ifdef _DEBUG_HOMARD_
 688           write (ulsort,texte(langue,8)) mess14(langue,3,2),
 689      >                                   mess14(langue,3,7)
 690 #endif
 691 c
 692           iaux = 7
 693           jaux = 2
 694 #ifdef _DEBUG_HOMARD_
 695       write (ulsort,texte(langue,3)) 'UTPPQT-PE_TR', nompro
 696 #endif
 697           call utppqt ( option, nbtrto, nbpeto, nbpecf,
 698      >                  iaux, jaux,
 699      >                  imem(pfacpe), imem(phetpe),
 700      >                  imem(advotr), lgpptr, imem(adpptr), nupptr,
 701      >                  ulsort, langue, codret )
 702 c
 703           endif
 704 c
 705 c 8.2.2. ==> Determination des pentaedres voisins des quadrangles
 706 c
 707           if ( codret.eq.0 ) then
 708 #ifdef _DEBUG_HOMARD_
 709           write (ulsort,texte(langue,8)) mess14(langue,3,4),
 710      >                                   mess14(langue,3,7)
 711 #endif
 712 c
 713           iaux = 7
 714           jaux = 4
 715 #ifdef _DEBUG_HOMARD_
 716       write (ulsort,texte(langue,3)) 'UTPPQT-PE_QU', nompro
 717 #endif
 718           call utppqt ( option, nbquto, nbpeto, nbpecf,
 719      >                  iaux, jaux,
 720      >                  imem(pfacpe), imem(phetpe),
 721      >                  imem(advoqu), lgppqu, imem(adppqu), nuppqu,
 722      >                  ulsort, langue, codret )
 723 c
 724           endif
 725 c
 726         endif
 727 c
 728       endif
 729 c
 730 c====
 731 c 9. la fin
 732 c====
 733 c
 734 #ifdef _DEBUG_HOMARD_
 735 cgn      call gmprsx (nompro,nhvois)
 736       if ( codret.eq.0 ) then
 737 cgn      call gmprsx (nompro,nhvois//'.Vol/Tri')
 738 cgn      call gmprsx (nompro,nhvois//'.PyPe/Tri')
 739 cgn      call gmprsx (nompro,nhvois//'.Vol/Qua')
 740       call gmprot (nompro,nhvois//'.Vol/Qua', 1, 30)
 741 cgn      call gmprsx (nompro,nhvois//'.PyPe/Qua')
 742       call gmprot (nompro,nhvois//'.PyPe/Qua', 1, 30)
 743       endif
 744 #endif
 745 c
 746       if ( codret.ne.0 ) then
 747 c
 748 #include "envex2.h"
 749 c
 750       write (ulsort,texte(langue,1)) 'Sortie', nompro
 751       write (ulsort,texte(langue,2)) codret
 752 c
 753       endif
 754 c
 755 #ifdef _DEBUG_HOMARD_
 756       write (ulsort,texte(langue,1)) 'Sortie', nompro
 757       call dmflsh (iaux)
 758 #endif
 759 c
 760       end