src/tool/AV_Conversion/vcorie.F

   1       subroutine vcorie ( eleinc, noeele, areele, typele,
   2      >                    somare, aretri, arequa,
   3      >                    nnosho, narsho, ntrsho, nqusho,
   4      >                    coexar,
   5      >                    tritet, cotrte, ntesho,
   6      >                    quahex, coquhe, nhesho,
   7      >                    facpen, cofape, npesho,
   8      >                    facpyr, cofapy, npysho,
   9      >                    ulsort, langue, codret  )
  10 c ______________________________________________________________________
  11 c
  12 c                             H O M A R D
  13 c
  14 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  15 c
  16 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  17 c aupres des huissiers de justice Simart et Lavoir a Clamart
  18 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  19 c aupres des huissiers de justice
  20 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  21 c
  22 c    HOMARD est une marque deposee d'Electricite de France
  23 c
  24 c Copyright EDF 1996
  25 c Copyright EDF 1998
  26 c Copyright EDF 2002
  27 c Copyright EDF 2020
  28 c ______________________________________________________________________
  29 c
  30 c    aVant adaptation - Conversion - ORIEntation
  31 c     -                 -            ----
  32 c ______________________________________________________________________
  33 c .        .     .        .                                            .
  34 c .  nom   . e/s . taille .           description                      .
  35 c ______________________________________________________________________
  36 c . eleinc . e   .   1    . elements incompatibles                     .
  37 c .        .     .        . 0 : on bloque s'il y en a                  .
  38 c .        .     .        . 1 : on les ignore s'il y en a              .
  39 c . noeele . e   . nbelem . noeuds des elements                        .
  40 c .        .     .*nbmane .                                            .
  41 c . areele . e   . nbelem . aretes des elements                        .
  42 c .        .     .*nbmaae .                                            .
  43 c . typele . e   . nbelem . type des elements pour le code de calcul   .
  44 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  45 c . aretri . es  .nbtrto*3. numeros des 3 aretes des triangles         .
  46 c . arequa . es  .nbquto*4. numeros des 4 aretes des quadrangles       .
  47 c . nnosho . e   . rsnoac . numero des noeuds dans HOMARD              .
  48 c . narsho . e   . rsarac . numero des aretes dans HOMARD              .
  49 c . ntrsho . e   . rstrac . numero des triangles dans HOMARD           .
  50 c . nqusho . e   . rsquac . numero des quadrangles dans HOMARD         .
  51 c . coexar . es  . nbarto*. codes de conditions aux limites portants   .
  52 c .        .     . nctfar . sur les aretes                             .
  53 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  54 c . cotrte .  s  .nbtecf*4. code des 4 triangles des tetraedres        .
  55 c . ntesho . e   . rsteac . numero des tetraedres dans HOMARD          .
  56 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  57 c . coquhe .  s  .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  58 c . nhesho . e   . rsheac . numero des hexaedres dans HOMARD           .
  59 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  60 c . cofape .  s  .nbpecf*5. codes des 5 faces des pentaedres           .
  61 c . npesho . e   . rspeac . numero des pentaedres dans HOMARD          .
  62 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  63 c . cofapy .  s  .nbpycf*5. codes des faces des pyramides              .
  64 c . npyrho . e   . repyac . numero des pyramides dans HOMARD           .
  65 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  66 c . langue . e   .    1   . langue des messages                        .
  67 c .        .     .        . 1 : francais, 2 : anglais                  .
  68 c . codret . es  .    1   . code de retour des modules                 .
  69 c .        .     .        . 0 : pas de probleme                        .
  70 c .        .     .        . 1 : probleme                               .
  71 c ______________________________________________________________________
  72 c
  73 c====
  74 c 0. declarations et dimensionnement
  75 c====
  76 c
  77 c 0.1. ==> generalites
  78 c
  79       implicit none
  80       save
  81 c
  82       character*6 nompro
  83       parameter ( nompro = 'VCORIE' )
  84 c
  85 #include "nblang.h"
  86 #include "referx.h"
  87 #include "cofaar.h"
  88 c
  89 c 0.2. ==> communs
  90 c
  91 #include "envex1.h"
  92 #include "dicfen.h"
  93 #include "refert.h"
  94 #include "refere.h"
  95 #include "nbutil.h"
  96 #include "nombar.h"
  97 #include "nombtr.h"
  98 #include "nombqu.h"
  99 #include "nombte.h"
 100 #include "nombhe.h"
 101 #include "nombpe.h"
 102 #include "nombpy.h"
 103 #include "nombsr.h"
 104 #include "envca1.h"
 105 #include "rftmed.h"
 106 #include "impr02.h"
 107 c
 108 c 0.3. ==> arguments
 109 c
 110       integer eleinc
 111       integer noeele(nbelem,nbmane)
 112       integer areele(nbelem,nbmaae)
 113       integer typele(nbelem)
 114       integer somare(2,nbarto), aretri(nbtrto,3)
 115       integer arequa(nbquto,4)
 116       integer nnosho(rsnoac), narsho(rsarac)
 117       integer ntrsho(rstrac), nqusho(rsquac)
 118       integer coexar(nbarto,nctfar)
 119       integer tritet(nbtecf,4), cotrte(nbtecf,4)
 120       integer ntesho(rsteac)
 121       integer quahex(nbhecf,6), coquhe(nbhecf,6)
 122       integer nhesho(rsheac)
 123       integer facpen(nbpecf,5), cofape(nbpecf,5)
 124       integer npesho(rspeac)
 125       integer facpyr(nbpycf,5), cofapy(nbpycf,5)
 126       integer npysho(rspyac)
 127 c
 128       integer ulsort, langue, codret
 129 c
 130 c 0.4. ==> variables locales
 131 c
 132       integer iaux
 133       integer elemen, typhom
 134       integer numfac
 135       integer letria, lequad
 136       integer letetr, lehexa, lepent, lapyra
 137       integer s1, s2
 138       integer sa1a2, sa1a3, sa1a4, sa2a3, sa3a4
 139       integer a1, a2, a3, a4
 140       integer orient
 141       integer code
 142 #ifdef _DEBUG_HOMARD_
 143       integer glop
 144 #endif
 145 c
 146       integer nbmess
 147       parameter ( nbmess = 10 )
 148       character*80 texte(nblang,nbmess)
 149 c
 150 c 0.5. ==> initialisations
 151 c ______________________________________________________________________
 152 c
 153 c====
 154 c 1. messages
 155 c====
 156 c
 157 #include "impr01.h"
 158 c
 159 #ifdef _DEBUG_HOMARD_
 160       write (ulsort,texte(langue,1)) 'Entree', nompro
 161       call dmflsh (iaux)
 162 #endif
 163 c
 164       texte(1,4) = '(''Element'',i10,'', de type HOMARD'',i4)'
 165       texte(1,5) =
 166      > '(4x,''==> '',a,i10,'', face de numero local'',i2,'' :'')'
 167       texte(1,7) = '(''Impossible de trouver le code'')'
 168 c
 169       texte(2,4) = '(''Element'',i10,'', with HOMARD type'',i4)'
 170       texte(2,5) = '(4x,''==> '',a,i10,'', local face position'',i2)'
 171       texte(2,7) = '(''Code cannot be found'')'
 172 c
 173 #include "impr03.h"
 174 c
 175 c====
 176 c 2. determination de l'orientation des aretes, des triangles et
 177 c    des quadrangles
 178 c====
 179 c
 180       do 20 , elemen = 1 , nbelem
 181 c
 182         typhom = medtrf(typele(elemen))
 183 c
 184 #ifdef _DEBUG_HOMARD_
 185         if ( elemen.eq.-12 ) then
 186           glop = 1
 187         else
 188           glop = 0
 189         endif
 190 #endif
 191 #ifdef _DEBUG_HOMARD_
 192         if ( glop.ne.0 ) then
 193         write (ulsort,texte(langue,4)) elemen, typhom
 194         endif
 195 #endif
 196 c
 197 c 2.1. ==> on saute si c'est un element incompatible avec le mode
 198 c          d'utilisation de HOMARD
 199 c
 200         if ( eleinc.ne.0 ) then
 201           if ( tyeref(typhom).ne.0 ) then
 202             goto 20
 203           endif
 204         endif
 205 c
 206 c 2.2. ==> les aretes
 207 c
 208 c     code de calcul : x--------x    HOMARD : x---------x
 209 c                      s1      s2             iaux      n2
 210 c
 211         if ( typhom.eq.tyhse1 .or. typhom.eq.tyhse2 ) then
 212 #ifdef _DEBUG_HOMARD_
 213         if ( glop.ne.0 ) then
 214        write (ulsort,90002) mess14(langue,1,1), narsho(elemen)
 215         endif
 216 #endif
 217 c
 218 c         s1 = numero dans HOMARD du 1er noeud de l'element dans MED
 219 c
 220           s1 = nnosho(noeele(elemen,1))
 221 c
 222 c         iaux = numero dans HOMARD du 1er noeud de l'arete
 223 c         narsho(elemen) correspondant a l'element elemen dans MED
 224 c
 225           iaux = somare(1,narsho(elemen))
 226 c
 227           if ( iaux.eq.s1 ) then
 228             orient =  1
 229           else
 230             orient = -1
 231           endif
 232 c
 233           coexar(narsho(elemen),coorfa) = orient
 234 c
 235 c 2.3. ==> les triangles
 236 c      en fonction du positionnement relatif des noeuds, on a une valeur
 237 c      d'orientation.
 238 c      il y a 6 possibilites :
 239 c      . la valeur absolue est le numero local MED du sommet en face
 240 c        de l'arete a1
 241 c      . on note positif quand la description par
 242 c        aretes (HOMARD) tourne dans le meme sens que la description
 243 c        par noeuds (MED), negatif pour le sens inverse :
 244 c
 245 c         s3                   s3                   s3
 246 c         /\                   /\                   /\
 247 c        /  \                 /  \                 /  \
 248 c     a2/  1 \a1           a1/  2 \a3           a3/  3 \a2
 249 c      /      \             /      \             /      \
 250 c     /________\           /________\           /________\
 251 c    s1   a3   s2         s1   a2   s2         s1   a1   s2
 252 c
 253 c         s3                   s3                   s3
 254 c         /\                   /\                   /\
 255 c        /  \                 /  \                 /  \
 256 c     a3/ -1 \a1           a1/ -2 \a2           a2/ -3 \a3
 257 c      /      \             /      \             /      \
 258 c     /________\           /________\           /________\
 259 c    s1   a2   s2         s1   a3   s2         s1   a1   s2
 260 c
 261 c      on va modifier la description du triangle pour faire coincider
 262 c      les numero si et les sommets des aretes ai, saiaj :
 263 c
 264 c                        s3                     sa2a3
 265 c                        /\                      /\
 266 c                MED :  /  \         HOMARD : a3/  \a2
 267 c                      /    \                  /    \
 268 c                     /______\                /______\
 269 c                    s1      s2            sa1a3 a1 sa1a2
 270 c
 271         elseif ( typhom.eq.tyhtr1 .or. typhom.eq.tyhtr2 ) then
 272 #ifdef _DEBUG_HOMARD_
 273         if ( glop.ne.0 ) then
 274        write (ulsort,90002) mess14(langue,1,2), ntrsho(elemen)
 275         endif
 276 #endif
 277 c
 278 c         numeros dans HOMARD du 1er et 2eme noeud
 279 c         de l'element elemen dans MED
 280 c
 281           s1 = nnosho(noeele(elemen,1))
 282           s2 = nnosho(noeele(elemen,2))
 283 c
 284 c         ak = numero dans HOMARD de la k-eme arete
 285 c         du triangle ntrsho(elemen) correspondant a l'element elemen
 286 c         dans MED
 287 c         sajak = numero dans HOMARD du noeud
 288 c         commun aux aretes aj et ak
 289 c
 290           a1 = aretri(ntrsho(elemen),1)
 291           a2 = aretri(ntrsho(elemen),2)
 292           a3 = aretri(ntrsho(elemen),3)
 293 c
 294           if ( somare(1,a1) .eq. somare(1,a3)  .or.
 295      >         somare(1,a1) .eq. somare(2,a3) ) then
 296 c           le 1er noeud de l'arete 1 est un des sommets de a3 ;
 297 c           donc le 2nd noeud de l'arete 1 est un des sommets de a2
 298             sa1a3 = somare(1,a1)
 299             sa1a2 = somare(2,a1)
 300           else
 301 c           le 1er noeud de l'arete 1 n'est pas un des sommets de a3 ;
 302 c           donc c'est qu'il est un des sommets de a2
 303 c           donc le 2nd noeud de l'arete 1 est un des sommets de a3
 304             sa1a3 = somare(2,a1)
 305             sa1a2 = somare(1,a1)
 306           endif
 307 c
 308 c         comparaison des deux numerotations
 309 c
 310           if ( s1 .eq. sa1a3 ) then
 311             if ( s2 .eq. sa1a2 ) then
 312 cgn              orient = 3
 313               aretri(ntrsho(elemen),1) = a2
 314               aretri(ntrsho(elemen),2) = a3
 315               aretri(ntrsho(elemen),3) = a1
 316             else
 317 cgn              orient = -2
 318               aretri(ntrsho(elemen),1) = a2
 319               aretri(ntrsho(elemen),2) = a1
 320               aretri(ntrsho(elemen),3) = a3
 321             endif
 322           elseif ( s1 .eq. sa1a2 ) then
 323             if ( s2 .eq. sa1a3 ) then
 324 cgn              orient = -3
 325               aretri(ntrsho(elemen),1) = a3
 326               aretri(ntrsho(elemen),3) = a1
 327             else
 328 cgn              orient = 2
 329               aretri(ntrsho(elemen),1) = a3
 330               aretri(ntrsho(elemen),2) = a1
 331               aretri(ntrsho(elemen),3) = a2
 332             endif
 333           else
 334 c           on a alors s1 .eq. sa2a3
 335             if ( s2 .ne. sa1a3 ) then
 336 cgn              orient = -1
 337               aretri(ntrsho(elemen),2) = a3
 338               aretri(ntrsho(elemen),3) = a2
 339 cgn            else
 340 cgn              orient = 1
 341             endif
 342           endif
 343 c
 344 c 2.4. ==> les quadrangles
 345 c      en fonction du positionnement relatif des noeuds, on a une valeur
 346 c      d'orientation.
 347 c      il y a 8 possibilites :
 348 c      . on note positif quand la description par
 349 c        aretes (HOMARD) tourne dans le meme sens que la description
 350 c        par noeuds (MED), negatif pour le sens inverse
 351 c      . la valeur absolue est le numero local MED du sommet commun
 352 c        aux aretes a1 et a4 si >0, a1 et a2 si <0
 353 c
 354 c      remarque : entre deux orientations de signes opposes,
 355 c                 les aretes 1 et 3 sont a la meme place et
 356 c                 les aretes 2 et 4 sont permutees.
 357 c
 358 c
 359 c   s1   a4   s4      s1   a3   s4      s1   a2   s4      s1   a1   s4
 360 c    .________.        .________.        .________.        .________.
 361 c    .        .        .        .        .        .        .        .
 362 c    .        .        .        .        .        .        .        .
 363 c  a1.    1   .a3    a4.    2   .a2    a3.    3   .a1    a2.    4   .a4
 364 c    .        .        .        .        .        .        .        .
 365 c    .________.        .________.        .________.        .________.
 366 c   s2   a2   s3      s2   a1   s3      s2   a4   s3      s2   a3   s3
 367 c
 368 c
 369 c
 370 c   s1   a2   s4      s1   a3   s4      s1   a4   s4      s1   a1   s4
 371 c    .________.        .________.        .________.        .________.
 372 c    .        .        .        .        .        .        .        .
 373 c    .        .        .        .        .        .        .        .
 374 c  a1.   -1   .a3    a2.   -2   .a4    a3.   -3   .a1    a4.   -4   .a2
 375 c    .        .        .        .        .        .        .        .
 376 c    .________.        .________.        .________.        .________.
 377 c   s2   a4   s3      s2   a1   s3      s2   a2   s3      s2   a3   s3
 378 c
 379 c      on va modifier la description du quadrangle pour faire coincider
 380 c      les numero si et les sommets des aretes ai, saiaj :
 381 c
 382 c
 383 c                  s1        s4               sa4a1   a4   sa3a4
 384 c                   .________.                    .________.
 385 c                   .        .                    .        .
 386 c                   .        .                    .        .
 387 c        MED :      .        .        HOMARD :  a1.        .a3
 388 c                   .        .                    .        .
 389 c                   .________.                    .________.
 390 c                  s2        s3               sa1a2   a2   sa2a3
 391 c
 392 c
 393         elseif ( typhom.eq.tyhqu1 .or. typhom.eq.tyhqu2 ) then
 394 #ifdef _DEBUG_HOMARD_
 395         if ( glop.ne.0 ) then
 396        write (ulsort,90002) mess14(langue,1,4), nqusho(elemen)
 397         endif
 398 #endif
 399 c
 400 c         numeros dans HOMARD du 1er et 2eme noeud
 401 c         de l'element elemen dans MED
 402 c
 403           s1 = nnosho(noeele(elemen,1))
 404           s2 = nnosho(noeele(elemen,2))
 405 c
 406 c         ak = numero dans HOMARD de la k-eme arete
 407 c         du quadrangle nqusho(elemen) correspondant a l'element elemen
 408 c         dans MED
 409 c         sajak = numero dans HOMARD du noeud
 410 c         commun aux aretes aj et ak
 411 c
 412 c         on commence par regarder si le sommet s1 est une extremite de
 413 c         l'arete a1
 414 c
 415           a1 = arequa(nqusho(elemen),1)
 416           a2 = arequa(nqusho(elemen),2)
 417           a3 = arequa(nqusho(elemen),3)
 418           a4 = arequa(nqusho(elemen),4)
 419 c
 420           if ( somare(1,a1) .eq. somare(1,a2)  .or.
 421      >         somare(1,a1) .eq. somare(2,a2) ) then
 422 c           le 1er noeud de l'arete 1 est un des sommets de a2 ;
 423 c           donc le 2nd noeud de l'arete 1 est un des sommets de a4
 424             sa1a2 = somare(1,a1)
 425             sa1a4 = somare(2,a1)
 426           else
 427 c           le 1er noeud de l'arete 1 n'est pas un des sommets de a2 ;
 428 c           donc c'est qu'il est un des sommets de a4
 429 c           donc le 2nd noeud de l'arete 1 est un des sommets de a2
 430             sa1a2 = somare(2,a1)
 431             sa1a4 = somare(1,a1)
 432           endif
 433 c
 434           if ( s1 .eq. sa1a4 ) then
 435             if ( s2 .ne. sa1a2 ) then
 436 cgn              orient = -4
 437               arequa(nqusho(elemen),1) = a4
 438               arequa(nqusho(elemen),2) = a3
 439               arequa(nqusho(elemen),3) = a2
 440               arequa(nqusho(elemen),4) = a1
 441 cgn            else
 442 cgn              orient = 1
 443             endif
 444           elseif ( s1 .eq. sa1a2 ) then
 445             if ( s2 .eq. sa1a4 ) then
 446 cgn              orient = -1
 447               arequa(nqusho(elemen),2) = a4
 448               arequa(nqusho(elemen),4) = a2
 449             else
 450 cgn              orient = 4
 451               arequa(nqusho(elemen),1) = a2
 452               arequa(nqusho(elemen),2) = a3
 453               arequa(nqusho(elemen),3) = a4
 454               arequa(nqusho(elemen),4) = a1
 455             endif
 456 c
 457           else
 458 c
 459 c           le sommet s1 n'est pas une extremite de l'arete a1
 460 c           il est donc un sommet de a3. on precise comment
 461 c
 462             if ( somare(1,a3) .eq. somare(1,a2)  .or.
 463      >           somare(1,a3) .eq. somare(2,a2) ) then
 464 c             le 1er noeud de l'arete 3 est un des sommets de a2 ;
 465 c             donc le 2nd noeud de l'arete 3 est un des sommets de a4
 466               sa2a3 = somare(1,a3)
 467               sa3a4 = somare(2,a3)
 468             else
 469 c             le 1er noeud de l'arete 3 n'est pas un des sommets de a2 ;
 470 c             donc c'est qu'il est un des sommets de a4
 471 c             donc le 2nd noeud de l'arete 3 est un des sommets de a2
 472               sa2a3 = somare(2,a3)
 473               sa3a4 = somare(1,a3)
 474             endif
 475 c
 476             if ( s1 .eq. sa3a4 ) then
 477               if ( s2 .eq. sa2a3 ) then
 478 cgn                orient = -3
 479                 arequa(nqusho(elemen),1) = a3
 480                 arequa(nqusho(elemen),3) = a1
 481               else
 482 cgn                orient = 2
 483                 arequa(nqusho(elemen),1) = a4
 484                 arequa(nqusho(elemen),2) = a1
 485                 arequa(nqusho(elemen),3) = a2
 486                 arequa(nqusho(elemen),4) = a3
 487               endif
 488             else
 489               if ( s2 .eq. sa3a4 ) then
 490 cgn                orient = 3
 491                 arequa(nqusho(elemen),1) = a3
 492                 arequa(nqusho(elemen),2) = a4
 493                 arequa(nqusho(elemen),3) = a1
 494                 arequa(nqusho(elemen),4) = a2
 495               else
 496 cgn                orient = -2
 497                 arequa(nqusho(elemen),1) = a2
 498                 arequa(nqusho(elemen),2) = a1
 499                 arequa(nqusho(elemen),3) = a4
 500                 arequa(nqusho(elemen),4) = a3
 501               endif
 502             endif
 503 c
 504           endif
 505 cgn          print *,elemen,nnosho(noeele(elemen,1)),
 506 cgn     >                   nnosho(noeele(elemen,2)),
 507 cgn     >                   nnosho(noeele(elemen,3)),
 508 cgn     >                   nnosho(noeele(elemen,4))
 509 cgn          print *,nqusho(elemen),arequa(nqusho(elemen),1),
 510 cgn     >                   arequa(nqusho(elemen),2),
 511 cgn     >                   arequa(nqusho(elemen),3),
 512 cgn     >                   arequa(nqusho(elemen),4)
 513 cgn      print *,orient
 514 c
 515         endif
 516 c
 517    20 continue
 518 c
 519 c====
 520 c 3. determination des codes des faces dans les volumes
 521 c====
 522 c
 523       do 30 , elemen = 1 , nbelem
 524 c
 525         typhom = medtrf(typele(elemen))
 526 c
 527 #ifdef _DEBUG_HOMARD_
 528         if ( elemen.ge.-12 ) then
 529           glop = 1
 530         else
 531           glop = 0
 532         endif
 533 #endif
 534 #ifdef _DEBUG_HOMARD_
 535         if ( glop.ne.0 ) then
 536         write (ulsort,texte(langue,4)) elemen, typhom
 537         endif
 538 #endif
 539 c
 540 c 3.1. ==> on saute si c'est un element incompatible avec le mode
 541 c          d'utilisation de HOMARD
 542 c
 543         if ( eleinc.ne.0 ) then
 544           if ( tyeref(typhom).ne.0 ) then
 545             goto 30
 546           endif
 547         endif
 548 c
 549 c 3.2. ==> les tetraedres
 550 c
 551         if ( typhom.eq.tyhte1 .or. typhom.eq.tyhte2 ) then
 552 c
 553           letetr = ntesho(elemen)
 554 c
 555 #ifdef _DEBUG_HOMARD_
 556         if ( glop.ne.0 ) then
 557         write (ulsort,*) ' '
 558         write (ulsort,90002) mess14(langue,2,3), letetr
 559         write (ulsort,90002) mess14(langue,3,1),
 560      >                       (areele(elemen,iaux),iaux=1,6)
 561         endif
 562 #endif
 563 c
 564           do 321 , iaux = 1 , 4
 565 c
 566             numfac = iaux
 567             letria = tritet(letetr,numfac)
 568 c
 569 #ifdef _DEBUG_HOMARD_
 570       write (ulsort,texte(langue,3)) 'VCORI1', nompro
 571 #endif
 572             call vcori1 ( elemen, typhom, numfac, letria,
 573      >                    areele, aretri,
 574      >                    code,
 575      >                    ulsort, langue, codret  )
 576             if ( codret.eq.0 ) then
 577               cotrte(letetr,numfac) = code
 578             endif
 579 c
 580   321     continue
 581 c
 582 c 3.3. ==> les hexaedres
 583 c
 584         elseif ( typhom.eq.tyhhe1 .or. typhom.eq.tyhhe2 ) then
 585 c
 586           lehexa = nhesho(elemen)
 587 c
 588 #ifdef _DEBUG_HOMARD_
 589         if ( glop.ne.0 ) then
 590         write (ulsort,*) ' '
 591         write (ulsort,90002) mess14(langue,2,6), lehexa
 592         write (ulsort,90002) mess14(langue,3,1),
 593      >                       (areele(elemen,iaux),iaux=1,6)
 594         write (ulsort,90002) mess14(langue,3,1),
 595      >                       (areele(elemen,iaux),iaux=7,12)
 596         endif
 597 #endif
 598 c
 599           do 331 , iaux = 1 , 6
 600 c
 601             numfac = iaux
 602             lequad = quahex(lehexa,numfac)
 603 c
 604 #ifdef _DEBUG_HOMARD_
 605       write (ulsort,texte(langue,3)) 'VCORI2', nompro
 606 #endif
 607             call vcori2 ( elemen, typhom, numfac, lequad,
 608      >                    areele, arequa,
 609      >                    code,
 610      >                    ulsort, langue, codret  )
 611             if ( codret.eq.0 ) then
 612               coquhe(lehexa,numfac) = code
 613             endif
 614 c
 615   331     continue
 616 c
 617 c 3.4. ==> les pentaedres
 618 c
 619         elseif ( typhom.eq.tyhpe1 .or. typhom.eq.tyhpe2 ) then
 620 c
 621           lepent = npesho(elemen)
 622 c
 623 #ifdef _DEBUG_HOMARD_
 624         if ( glop.ne.0 ) then
 625         write (ulsort,*) ' '
 626         write (ulsort,90002) mess14(langue,2,7), lepent
 627         write (ulsort,90002) mess14(langue,3,1),
 628      >                       (areele(elemen,iaux),iaux=1,9)
 629         endif
 630 #endif
 631 c
 632           do 341 , iaux = 1 , 2
 633 c
 634             numfac = iaux
 635             letria = facpen(lepent,numfac)
 636 c
 637 #ifdef _DEBUG_HOMARD_
 638       write (ulsort,texte(langue,3)) 'VCORI1', nompro
 639 #endif
 640             call vcori1 ( elemen, typhom, numfac, letria,
 641      >                    areele, aretri,
 642      >                    code,
 643      >                    ulsort, langue, codret  )
 644             if ( codret.eq.0 ) then
 645               cofape(lepent,iaux) = code
 646             endif
 647 c
 648   341     continue
 649 c
 650           do 344 , iaux = 3 , 5
 651 c
 652             numfac = iaux
 653             lequad = facpen(lepent,numfac)
 654 c
 655 #ifdef _DEBUG_HOMARD_
 656       write (ulsort,texte(langue,3)) 'VCORI2', nompro
 657 #endif
 658             call vcori2 ( elemen, typhom, numfac, lequad,
 659      >                    areele, arequa,
 660      >                    code,
 661      >                    ulsort, langue, codret  )
 662             if ( codret.eq.0 ) then
 663               cofape(lepent,numfac) = code
 664             endif
 665 c
 666   344     continue
 667 c
 668 c 3.5. ==> les pyramides
 669 c
 670         elseif ( typhom.eq.tyhpy1 .or. typhom.eq.tyhpy2 ) then
 671 c
 672           lapyra = npysho(elemen)
 673 c
 674 #ifdef _DEBUG_HOMARD_
 675         if ( glop.ne.0 ) then
 676         write (ulsort,*) ' '
 677         write (ulsort,90002) mess14(langue,2,5), lapyra
 678         write (ulsort,90002) mess14(langue,3,1),
 679      >                       (areele(elemen,iaux),iaux=1,8)
 680         endif
 681 #endif
 682 c
 683           do 351 , iaux = 1 , 4
 684 c
 685             numfac = iaux
 686             letria = facpyr(lapyra,numfac)
 687 c
 688 #ifdef _DEBUG_HOMARD_
 689       write (ulsort,texte(langue,3)) 'VCORI1', nompro
 690 #endif
 691             call vcori1 ( elemen, typhom, numfac, letria,
 692      >                    areele, aretri,
 693      >                    code,
 694      >                    ulsort, langue, codret  )
 695             if ( codret.eq.0 ) then
 696               cofapy(lapyra,numfac) = code
 697             endif
 698 c
 699   351     continue
 700 c
 701           numfac = 5
 702           lequad = facpyr(lapyra,numfac)
 703 c
 704 #ifdef _DEBUG_HOMARD_
 705       write (ulsort,texte(langue,3)) 'VCORI2', nompro
 706 #endif
 707           call vcori2 ( elemen, typhom, numfac, lequad,
 708      >                  areele, arequa,
 709      >                  code,
 710      >                  ulsort, langue, codret  )
 711           if ( codret.eq.0 ) then
 712             cofapy(lapyra,numfac) = code
 713           endif
 714 c
 715         endif
 716 c
 717    30 continue
 718 c
 719 c====
 720 c 4. la fin
 721 c====
 722 c
 723       if ( codret.ne.0 ) then
 724 c
 725 #include "envex2.h"
 726 c
 727       write (ulsort,texte(langue,1)) 'Sortie', nompro
 728       write (ulsort,texte(langue,2)) codret
 729       endif
 730 c
 731 #ifdef _DEBUG_HOMARD_
 732       write (ulsort,texte(langue,1)) 'Sortie', nompro
 733       call dmflsh (iaux)
 734 #endif
 735 c
 736       end