src/tool/Utilitaire/utconf.F

   1       subroutine utconf ( nbarto, nbtrto, nbquto,
   2      >                    nbteto, nbheto, nbpyto, nbpeto,
   3      >                    nbteca, nbheca, nbpyca, nbpeca,
   4      >                    nbtecf, nbhecf, nbpycf, nbpecf,
   5      >                    hetare,
   6      >                    hettri, aretri,
   7      >                    hetqua, arequa,
   8      >                    hettet, tritet, cotrte,
   9      >                    hethex, quahex, coquhe,
  10      >                    hetpyr, facpyr, cofapy,
  11      >                    hetpen, facpen, cofape,
  12      >                    optnco, optimp,
  13      >                    ulsort, langue, codret )
  14 c ______________________________________________________________________
  15 c
  16 c                             H O M A R D
  17 c
  18 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  19 c
  20 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  21 c aupres des huissiers de justice Simart et Lavoir a Clamart
  22 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  23 c aupres des huissiers de justice
  24 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  25 c
  26 c    HOMARD est une marque deposee d'Electricite de France
  27 c
  28 c Copyright EDF 1996
  29 c Copyright EDF 1998
  30 c Copyright EDF 2002
  31 c Copyright EDF 2020
  32 c ______________________________________________________________________
  33 c
  34 c    UTilitaire - verification de la CONFormite du maillage
  35 c    --                              ----
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  41 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  42 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  43 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  44 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  45 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  46 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  47 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  48 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  49 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  50 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  51 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  52 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  53 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  54 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  55 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  56 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  57 c . optnco . e   .   1    . option des non-conformites :               .
  58 c .        .     .        . 0 : le maillage doit etre 100% conforme    .
  59 c .        .     .        . 1 : au minimum 2 aretes non coupees par fac.
  60 c .        .     .        . 2 : 1 seul noeud pendant par arete         .
  61 c .        .     .        . -1 : le maillage doit etre 100% conforme   .
  62 c .        .     .        . -2 : 1 seule arete coupee par maille 2D    .
  63 c . optimp . e   .   1    . option d'impression des non-conformites :  .
  64 c .        .     .        . 0 : pas d'impression                       .
  65 c .        .     .        . non nul : impression                       .
  66 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  67 c . langue . e   .    1   . langue des messages                        .
  68 c .        .     .        . 1 : francais, 2 : anglais                  .
  69 c . codret . es  .    1   . code de retour des modules                 .
  70 c .        .     .        . 0 : pas de probleme                        .
  71 c .        .     .        . 2 : pb. de conformite sur les triangles    .
  72 c .        .     .        . 3 : pb. de conformite sur les tetraedres   .
  73 c .        .     .        . 4 : pb. de conformite sur les quadrangles  .
  74 c ______________________________________________________________________
  75 c
  76 c====
  77 c 0. declarations et dimensionnement
  78 c====
  79 c
  80 c 0.1. ==> generalites
  81 c
  82       implicit none
  83       save
  84 c
  85       character*6 nompro
  86       parameter ( nompro = 'UTCONF' )
  87 c
  88 #include "nblang.h"
  89 c
  90 c 0.2. ==> communs
  91 c
  92 #include "envex1.h"
  93 c
  94 #include "impr02.h"
  95 c
  96 c 0.3. ==> arguments
  97 c
  98       integer nbarto, nbtrto, nbquto
  99       integer nbteto, nbheto, nbpyto, nbpeto
 100       integer nbteca, nbheca, nbpyca, nbpeca
 101       integer nbtecf, nbhecf, nbpycf, nbpecf
 102       integer hetare(nbarto)
 103       integer hettri(nbtrto), aretri(nbtrto,3)
 104       integer hetqua(nbquto), arequa(nbquto,4)
 105       integer hettet(nbteto), tritet(nbtecf,4), cotrte(nbtecf,4)
 106       integer hethex(nbheto), quahex(nbhecf,6), coquhe(nbhecf,6)
 107       integer hetpyr(nbpyto), facpyr(nbpycf,5), cofapy(nbpycf,5)
 108       integer hetpen(nbpeto), facpen(nbpecf,5), cofape(nbpecf,5)
 109       integer optnco, optimp
 110 c
 111       integer ulsort, langue, codret
 112 c
 113 c 0.4. ==> variables locales
 114 c
 115       integer nbtrnc, nbqunc
 116       integer nbtenc, nbhenc, nbpync, nbpenc
 117       integer entite, letria, lequad
 118       integer larete, etat, bilanc
 119       integer iaux, jaux
 120       integer listar(12)
 121       integer nbard2, nbarde
 122       integer nbtrd2, nbtrd4
 123       integer nbqud3, nbqud4
 124 c
 125       integer nbmess
 126       parameter ( nbmess = 20 )
 127       character*80 texte(nblang,nbmess)
 128 c
 129 c 0.5. ==> initialisations
 130 c ______________________________________________________________________
 131 c
 132 c====
 133 c 1. impression
 134 c====
 135 c
 136 #include "impr01.h"
 137 c
 138 #ifdef _DEBUG_HOMARD_
 139       write (ulsort,texte(langue,1)) 'Entree', nompro
 140       call dmflsh (iaux)
 141 #endif
 142 c
 143       texte(1,4) =
 144      >'(''Les mailles doivent avoir au maximum 1 arete coupee.'')'
 145       texte(1,5) = '(''Le maillage doit etre 100% conforme.'')'
 146       texte(1,6) = texte(1,5)
 147       texte(1,7) =
 148      >'(''Les mailles doivent avoir au minimum 2 aretes non coupees.'')'
 149       texte(1,8) =
 150      > '(''Les aretes actives peuvent avoir un noeud pendant.'')'
 151       texte(1,9) =
 152      > '(/,''Le maillage a plus d''''un point de non-conformite.'')'
 153       texte(1,10) =
 154      > '(/,''Les '',a,''n''''ont pas de probleme de non-conformite.'')'
 155       texte(1,11) =
 156      > '(/,''ATTENTION : le maillage n''''est pas conforme.'')'
 157       texte(1,12) = '(''Le '',a,i10,'' a un probleme de conformite.'')'
 158       texte(1,13) =
 159      > '(2x,a,i1,'' : numero = '',i10,'', etat = '',i4)'
 160       texte(1,14) =
 161      > '(''Nombre de '',a,'' actifs a problemes  : '',i10,/)'
 162       texte(1,15) = '(''Son etat vaut '',i10)'
 163       texte(1,16) = '(''Nombre de '',a,'' : '',i10)'
 164       texte(1,20) = '(''Examen du '',a,i10)'
 165 c
 166       texte(2,4) = '(''Meshes whould have at max 1 cut edge.'')'
 167       texte(2,5) = '(''Mesh should be 100% conformal.'')'
 168       texte(2,6) = texte(2,5)
 169       texte(2,7) = '(''Meshes should have at min 2 non cut edges.'')'
 170       texte(2,8) = '(''Active edges could have one hanging node.'')'
 171       texte(2,9) = '(/,''Mesh contains more than 1 hanging node.'')'
 172       texte(2,10) = '(/,''No conformity problem with '', a)'
 173       texte(2,11) = '(/,''CAUTION : mesh contains hanging nodes.'')'
 174       texte(2,12) =
 175      > '(''The active '',a,'' # '',i10,'' has a conformity problem'')'
 176       texte(2,13) =
 177      > '(2x,a,i1,'' : # '',i10,'', state = '',i4)'
 178       texte(2,14) =
 179      > '(''Number of active '',a,'' with problems : '',i10,/)'
 180       texte(2,15) = '(''Its state is equal to '',i10)'
 181       texte(2,16) = '(''Number of '',a,'' : '',i10)'
 182       texte(2,20) = '(''Examination of the'',a,i10)'
 183 c
 184 #include "impr03.h"
 185 c
 186       codret = 0
 187 c
 188 #ifdef _DEBUG_HOMARD_
 189        write(ulsort,texte(langue,6+optnco))
 190 #endif
 191 c
 192 #ifdef _DEBUG_HOMARD_
 193        write(ulsort,texte(langue,16)) mess14(langue,3,2), nbtrto
 194        write(ulsort,texte(langue,16)) mess14(langue,3,4), nbquto
 195        write(ulsort,texte(langue,16)) mess14(langue,3,3), nbteto
 196        write(ulsort,texte(langue,16)) mess14(langue,3,5), nbpyto
 197        write(ulsort,texte(langue,16)) mess14(langue,3,6), nbheto
 198        write(ulsort,texte(langue,16)) mess14(langue,3,7), nbpeto
 199 #endif
 200 c
 201 c====
 202 c 2. verification de la conformite des triangles
 203 c====
 204 #ifdef _DEBUG_HOMARD_
 205        write(ulsort,90002) '2. verif triangles, codret', codret
 206 #endif
 207 c
 208       if ( nbtrto.ne.0 ) then
 209 c
 210       nbtrnc = 0
 211 c
 212       do 20 , entite = 1 , nbtrto
 213 c
 214         etat = mod (hettri(entite),10)
 215 c
 216         if ( etat.eq.0 ) then
 217 c
 218 #ifdef _DEBUG_HOMARD_
 219        write(ulsort,texte(langue,20)) mess14(langue,1,2), entite
 220 #endif
 221 c
 222 c 2.1. ==> Decompte du nombre d'aretes actives
 223 c
 224           nbard2 = 0
 225           nbarde = 0
 226           do 21 , jaux = 1 , 3
 227             iaux = mod (hetare(aretri(entite,jaux)),10)
 228             if ( iaux.eq.2 ) then
 229               nbard2 = nbard2 + 1
 230             elseif ( iaux.ne.0 ) then
 231               nbarde = nbarde + 1
 232             endif
 233    21     continue
 234           bilanc = max ( nbard2, nbarde )
 235 cgn          print *,mess14(langue,1,1), entite, ':',nbard2, nbarde
 236 c
 237 c 2.2. ==> S'il y a au moins une arete inactive, precision pour le cas
 238 c          non conforme
 239 c
 240           if ( optnco.ne.0 .and. bilanc.ge.1 ) then
 241 c
 242 c 2.2.1. ==> optnco = 1 : autorise 1 seule arete coupee par maille
 243 c
 244             if ( optnco.eq.1 ) then
 245 c
 246               if ( nbard2.le.1 .and. nbarde.eq.0 ) then
 247                 bilanc = 0
 248               endif
 249 c
 250 c 2.2.2. ==> optnco = 2 : autorise 1 seul noeud pendant par arete
 251 c
 252             else
 253 c
 254               if ( nbarde.eq.0 ) then
 255                 bilanc = 0
 256               endif
 257 c
 258             endif
 259 c
 260           endif
 261 cgn          print *,mess14(langue,1,3), entite, ':',bilanc
 262 c
 263 c 2.3. ==> Bilan avec impression eventuelle
 264 c
 265           if ( bilanc.ne.0 ) then
 266             nbtrnc = nbtrnc + 1
 267             if ( optimp.ne.0 ) then
 268               write(ulsort,texte(langue,12)) mess14(langue,1,2),
 269      >                                      entite
 270               write(ulsort,texte(langue,15)) hettri(entite)
 271               do 23 , iaux = 1 , 3
 272                 larete = aretri(entite,iaux)
 273                 write(ulsort,texte(langue,13)) mess14(langue,2,1),
 274      >                                  iaux, larete, hetare(larete)
 275    23         continue
 276             endif
 277           endif
 278 c
 279         endif
 280 c
 281    20 continue
 282 c
 283       if ( nbtrnc.ne.0 ) then
 284         codret = 2
 285 #ifdef _DEBUG_HOMARD_
 286         if ( optimp.ne.0 ) then
 287 #else
 288         if ( ulsort.ne.0 ) then
 289 #endif
 290           if ( optnco.eq.0 ) then
 291             write(ulsort,texte(langue,11))
 292           else
 293             write(ulsort,texte(langue,9))
 294           endif
 295           write(ulsort,texte(langue,14)) mess14(langue,3,2), nbtrnc
 296         endif
 297 #ifdef _DEBUG_HOMARD_
 298       else
 299         write(ulsort,texte(langue,10)) mess14(langue,3,2)
 300 #endif
 301       endif
 302 c
 303       endif
 304 c
 305 c====
 306 c 3. verification de la conformite des quadrangles
 307 c====
 308 #ifdef _DEBUG_HOMARD_
 309       write (ulsort,90002) '3. verif quadrangles ; codret', codret
 310 #endif
 311 c
 312       if ( nbquto.ne.0 ) then
 313 c
 314       nbqunc = 0
 315 c
 316       do 30 , entite = 1 , nbquto
 317 c
 318         etat = mod ( hetqua(entite),100)
 319 c
 320         if ( etat.eq.0 ) then
 321 c
 322 #ifdef _DEBUG_HOMARD_
 323        write(ulsort,texte(langue,20)) mess14(langue,1,4), entite
 324 #endif
 325 c
 326 c 3.1. ==> Decompte du nombre d'aretes actives
 327 c
 328           nbard2 = 0
 329           nbarde = 0
 330           do 31 , jaux = 1 , 4
 331             iaux = mod (hetare(arequa(entite,jaux)),10)
 332             if ( iaux.eq.2 ) then
 333               nbard2 = nbard2 + 1
 334             elseif ( iaux.ne.0 ) then
 335               nbarde = nbarde + 1
 336             endif
 337    31     continue
 338           bilanc = max ( nbard2, nbarde )
 339 cgn          print *,mess14(langue,1,1), entite, ':',nbard2, nbarde
 340 c
 341 c 3.2. ==> S'il y a au moins une arete inactive, precision pour le cas
 342 c          non conforme
 343 c
 344           if ( optnco.ne.0 .and. bilanc.ge.1 ) then
 345 c
 346 c 3.2.1. ==> optnco = 1 : au maximum 2 aretes coupees
 347 c
 348             if ( optnco.eq.1 ) then
 349 c
 350               if ( nbard2.le.2 .and. nbarde.eq.0 ) then
 351                 bilanc = 0
 352               endif
 353 c
 354 c 3.2.2. ==> optnco = 2 : autorise 1 seul noeud pendant par arete
 355 c
 356             else
 357 c
 358               if ( nbarde.eq.0 ) then
 359                 bilanc = 0
 360               endif
 361 c
 362             endif
 363 c
 364           endif
 365 cgn          print *,mess14(langue,1,3), entite, ':',bilanc
 366 c
 367 c 3.3. ==> Bilan avec impression eventuelle
 368 c
 369           if ( bilanc.ne.0 ) then
 370             nbqunc = nbqunc + 1
 371             if ( optimp.ne.0 ) then
 372               write(ulsort,texte(langue,12)) mess14(langue,1,4),
 373      >                                      entite
 374               write(ulsort,texte(langue,15)) hetqua(entite)
 375               do 33 , iaux = 1 , 4
 376                 larete = arequa(entite,iaux)
 377                 write(ulsort,texte(langue,13)) mess14(langue,2,1),
 378      >                                  iaux, larete, hetare(larete)
 379    33         continue
 380             endif
 381           endif
 382 c
 383         endif
 384 c
 385    30 continue
 386 c
 387       if ( nbqunc.ne.0 ) then
 388         codret = 4
 389 #ifdef _DEBUG_HOMARD_
 390         if ( optimp.ne.0 ) then
 391 #else
 392         if ( ulsort.ne.0 ) then
 393 #endif
 394           if ( optnco.eq.0 ) then
 395             write(ulsort,texte(langue,11))
 396           else
 397             write(ulsort,texte(langue,9))
 398           endif
 399           write(ulsort,texte(langue,14)) mess14(langue,3,4), nbqunc
 400         endif
 401 #ifdef _DEBUG_HOMARD_
 402       else
 403         write(ulsort,texte(langue,10)) mess14(langue,3,4)
 404 #endif
 405       endif
 406 c
 407       endif
 408 c
 409 c====
 410 c 4. verification de la conformite des tetraedres
 411 c    On ne controle pas pour l'option "1 noeud pendant" car c'est pris
 412 c    en compte par les faces
 413 c====
 414 #ifdef _DEBUG_HOMARD_
 415       write (ulsort,90002) '4. verif tetraedres ; codret', codret
 416 #endif
 417 c
 418       if ( nbteto.ne.0 .and. optnco.le.1 ) then
 419 c
 420       nbtenc = 0
 421 c
 422       do 40 , entite = 1 , nbtecf
 423 c
 424         etat = mod (hettet(entite) , 100 )
 425 c
 426         if ( etat.eq.0 ) then
 427 #ifdef _DEBUG_HOMARD_
 428        write(ulsort,texte(langue,20)) mess14(langue,1,3), entite
 429 #endif
 430 c
 431 c 4.1. ==> Decompte du nombre de faces actives
 432 c
 433           nbtrd2 = 0
 434           nbtrd4 = 0
 435           do 41 , jaux = 1 , 4
 436             iaux = mod (hettri(tritet(entite,jaux)),10)
 437             if ( iaux.ge.1 .and. iaux.le.3 ) then
 438               nbtrd2 = nbtrd2 + 1
 439             elseif ( iaux.ge.4 .and. iaux.le.8 ) then
 440               nbtrd4 = nbtrd4 + 1
 441             elseif ( iaux.eq.9 ) then
 442               nbtrd4 = nbtrd4 + 2
 443             endif
 444    41     continue
 445 cgn          print *,mess14(langue,1,3), entite, ':',nbtrd2, nbtrd4
 446           bilanc = max ( nbtrd2, nbtrd4 )
 447 c
 448 c 4.2. ==> S'il y a au moins une face inactive, precision pour le cas
 449 c          non conforme
 450 c
 451           if ( optnco.ne.0 .and. bilanc.ge.1 ) then
 452 c
 453 c 4.2.1. ==> optnco = 1, on autorise :
 454 c            - 1 triangle coupe en 4, les 3 autres aretes non coupees
 455 c         ou - 1 ou 2 triangles coupes en 2, 1 seule arete coupee
 456 c
 457             if ( optnco.eq.1 ) then
 458 c
 459               if ( ( nbtrd2.eq.0 .and. nbtrd4.eq.1 ) .or.
 460      >             ( nbtrd2.le.2 .and. nbtrd4.eq.0 ) ) then
 461 c
 462 #ifdef _DEBUG_HOMARD_
 463       write (ulsort,texte(langue,3)) 'UTARTE', nompro
 464 #endif
 465                 call utarte ( entite,
 466      >                        nbtrto, nbtecf,
 467      >                        aretri, tritet, cotrte,
 468      >                        listar )
 469                 iaux = 0
 470                 do 42 , jaux = 1 , 6
 471                   if ( mod(hetare(listar(jaux)),10).ne.0 ) then
 472                     iaux = iaux + 1
 473                   endif
 474    42           continue
 475 c
 476                 if ( nbtrd4.eq.0 ) then
 477                   if ( iaux.eq.1 ) then
 478                     bilanc = 0
 479                   endif
 480                 else
 481                   if ( iaux.eq.3 ) then
 482                     bilanc = 0
 483                   endif
 484                 endif
 485 c
 486               endif
 487 c
 488             endif
 489 c
 490           endif
 491 cgn          print *,mess14(langue,1,3), entite, ':',bilanc
 492 c
 493 c 4.3. ==> Bilan avec impression eventuelle
 494 c
 495           if ( bilanc.ne.0 ) then
 496 c
 497             nbtenc = nbtenc + 1
 498             if ( optimp.ne.0 ) then
 499               write(ulsort,texte(langue,12)) mess14(langue,1,3),
 500      >                                       entite
 501               write(ulsort,texte(langue,15)) hettet(entite)
 502               do 431 , iaux = 1 , 4
 503                 letria = tritet(entite,iaux)
 504                 write(ulsort,texte(langue,13)) mess14(langue,2,2),
 505      >                                  iaux, letria, hettri(letria)
 506                 do 4311 , jaux = 1 , 3
 507                   larete = aretri(letria,jaux)
 508                   write(ulsort,texte(langue,13))
 509      >                                    '  '//mess14(langue,2,1),
 510      >                                    jaux, larete, hetare(larete)
 511  4311           continue
 512   431         continue
 513             endif
 514 c
 515           endif
 516 c
 517         endif
 518 c
 519    40 continue
 520 c
 521       if ( nbtenc.ne.0 ) then
 522         codret = 3
 523 #ifdef _DEBUG_HOMARD_
 524         if ( optimp.ne.0 ) then
 525 #else
 526         if ( ulsort.ne.0 ) then
 527 #endif
 528           if ( optnco.eq.0 ) then
 529             write(ulsort,texte(langue,11))
 530           else
 531             write(ulsort,texte(langue,9))
 532           endif
 533           write(ulsort,texte(langue,14)) mess14(langue,3,3), nbtenc
 534         endif
 535 #ifdef _DEBUG_HOMARD_
 536       else
 537         write(ulsort,texte(langue,10)) mess14(langue,3,3)
 538 #endif
 539       endif
 540 c
 541       endif
 542 c
 543 c====
 544 c 5. verification de la conformite des pyramides
 545 c    On ne controle pas pour l'option "1 noeud pendant" car c'est pris
 546 c    en compte par les faces
 547 c====
 548 #ifdef _DEBUG_HOMARD_
 549       write (ulsort,90002) '5. verif pyramides ; codret', codret
 550 #endif
 551 c
 552       if ( nbpyto.ne.0 .and. optnco.le.1 ) then
 553 c
 554       nbpync = 0
 555 c
 556       do 50 , entite = 1 , nbpycf
 557 c
 558         etat = mod ( hetpyr(entite) , 100 )
 559 c
 560         if ( etat.eq.0 ) then
 561 c
 562 #ifdef _DEBUG_HOMARD_
 563        write(ulsort,texte(langue,20)) mess14(langue,1,5), entite
 564 #endif
 565 c
 566 c 5.1. ==> Decompte du nombre de faces actives
 567 c
 568           nbtrd2 = 0
 569           nbtrd4 = 0
 570           do 51 , jaux = 1 , 4
 571             iaux = mod (hettri(facpyr(entite,jaux)),10)
 572             if ( iaux.ge.1 .and. iaux.le.3 ) then
 573               nbtrd2 = nbtrd2 + 1
 574             elseif ( iaux.ge.4 .and. iaux.le.8 ) then
 575               nbtrd4 = nbtrd4 + 1
 576             elseif ( iaux.eq.9 ) then
 577               nbtrd4 = nbtrd4 + 2
 578             endif
 579    51     continue
 580           nbqud3 = 0
 581           nbqud4 = 0
 582           iaux = mod (hetqua(facpyr(entite,5)),100)
 583           if ( iaux.eq.4 ) then
 584             nbqud4 = 1
 585           elseif ( iaux.eq.99 ) then
 586             nbqud4 = 2
 587           elseif ( iaux.ne.0 ) then
 588             nbqud3 = 1
 589           endif
 590 c
 591 c 5.2. ==> S'il y a au moins une face inactive, precision pour le cas
 592 c          non conforme
 593 c          On autorise :
 594 c          - 1 face coupee en 4, les autres aretes non coupees
 595 c          - 1 ou 2 triangles coupes en 2, 1 seule arete coupee
 596 c          - 1 quadrangle coupe en 3, 1 seule arete coupee
 597 c          - 1 triangle coupe en 2 et 1 quadrangle coupe en 3,
 598 c            1 seule arete coupee
 599 c
 600           if ( optnco.ne.0 .and. bilanc.ge.1 ) then
 601 c
 602             if ( ( nbtrd2.eq.0 .and. nbtrd4.eq.1 .and.
 603      >             nbqud3.eq.0 .and. nbqud4.eq.0 ) .or.
 604      >           ( nbtrd2.eq.0 .and. nbtrd4.eq.0 .and.
 605      >             nbqud3.eq.0 .and. nbqud4.eq.1 ) .or.
 606      >           ( nbtrd2.le.2 .and. nbtrd4.eq.0 .and.
 607      >             nbqud3.eq.0 .and. nbqud4.eq.0 ) .or.
 608      >           ( nbtrd2.le.1 .and. nbtrd4.eq.0 .and.
 609      >             nbqud3.eq.1 .and. nbqud4.eq.0 ) ) then
 610 c
 611 #ifdef _DEBUG_HOMARD_
 612       write (ulsort,texte(langue,3)) 'UTARPY', nompro
 613 #endif
 614               call utarpy ( entite,
 615      >                      nbtrto, nbpycf,
 616      >                      aretri, facpyr, cofapy,
 617      >                      listar )
 618               iaux = 0
 619               do 52 , jaux = 1 , 8
 620                 if ( mod(hetare(listar(jaux)),10).ne.0 ) then
 621                   iaux = iaux + 1
 622                 endif
 623    52         continue
 624 c
 625               if ( nbtrd4.eq.0 .and. nbqud4.eq.0 ) then
 626                 if ( iaux.eq.1 ) then
 627                   bilanc = 0
 628                 endif
 629               elseif ( nbtrd4.eq.1 ) then
 630                 if ( iaux.eq.3 ) then
 631                   bilanc = 0
 632                 endif
 633               elseif ( nbqud4.eq.1 ) then
 634                 if ( iaux.eq.4 ) then
 635                   bilanc = 0
 636                 endif
 637               endif
 638 c
 639             endif
 640 c
 641           endif
 642 cgn          print *,mess14(langue,1,3), entite, ':',bilanc
 643 c
 644 c 5.3. ==> Bilan avec impression eventuelle
 645 c
 646           if ( bilanc.ne.0 ) then
 647             nbpync = nbpync + 1
 648             if ( optimp.ne.0 ) then
 649               write(ulsort,texte(langue,12)) mess14(langue,1,5),
 650      >                                      entite
 651               write(ulsort,texte(langue,15)) hetpyr(entite)
 652               do 531 , iaux = 1 , 4
 653                 letria = facpyr(entite,iaux)
 654                 write(ulsort,texte(langue,13)) mess14(langue,2,2),
 655      >                                  iaux, letria, hettri(letria)
 656                 do 5311 , jaux = 1 , 3
 657                   larete = aretri(letria,jaux)
 658                   write(ulsort,texte(langue,13))
 659      >                                   '  '//mess14(langue,2,1),
 660      >                                    jaux, larete, hetare(larete)
 661  5311           continue
 662   531         continue
 663               lequad = facpyr(entite,5)
 664               write(ulsort,texte(langue,13)) mess14(langue,2,4),
 665      >                                1, lequad, hetqua(lequad)
 666               do 532 , jaux = 1 , 4
 667                 larete = arequa(lequad,jaux)
 668                 write(ulsort,texte(langue,13))
 669      >                                  '  '//mess14(langue,2,1),
 670      >                                  jaux, larete, hetare(larete)
 671   532         continue
 672             endif
 673           endif
 674 c
 675         endif
 676 c
 677    50 continue
 678 c
 679       if ( nbpync.ne.0 ) then
 680         codret = 5
 681 #ifdef _DEBUG_HOMARD_
 682         if ( optimp.ne.0 ) then
 683 #else
 684         if ( ulsort.ne.0 ) then
 685 #endif
 686           if ( optnco.eq.0 ) then
 687             write(ulsort,texte(langue,11))
 688           else
 689             write(ulsort,texte(langue,9))
 690           endif
 691           write(ulsort,texte(langue,14)) mess14(langue,3,5), nbpync
 692         endif
 693 #ifdef _DEBUG_HOMARD_
 694       else
 695         write(ulsort,texte(langue,10)) mess14(langue,3,5)
 696 #endif
 697       endif
 698 c
 699       endif
 700 c
 701 c====
 702 c 6. verification de la conformite des hexaedres
 703 c    On ne controle pas pour l'option "1 noeud pendant" car c'est pris
 704 c    en compte par les faces
 705 c====
 706 #ifdef _DEBUG_HOMARD_
 707       write (ulsort,90002) '6. verif hexaedres ; codret', codret
 708 #endif
 709 c
 710       if ( nbheto.ne.0 .and. optnco.le.1 ) then
 711 c
 712       nbhenc = 0
 713 c
 714       do 60 , entite = 1 , nbhecf
 715 c
 716         etat = mod(hethex(entite),1000)
 717 c
 718         if ( etat.eq.0 ) then
 719 c
 720 #ifdef _DEBUG_HOMARD_
 721        write(ulsort,texte(langue,20)) mess14(langue,1,6), entite
 722 #endif
 723 c
 724 c 6.1. ==> Decompte du nombre de faces actives
 725 c
 726           nbqud3 = 0
 727           nbqud4 = 0
 728           do 61 , jaux = 1 , 6
 729             iaux = mod (hetqua(quahex(entite,jaux)),100)
 730             if ( iaux.eq.4 ) then
 731               nbqud4 = nbqud4 + 1
 732             elseif ( iaux.eq.99 ) then
 733               nbqud4 = nbqud4 + 2
 734             elseif ( iaux.ne.0 ) then
 735               nbqud3 = nbqud3 + 1
 736             endif
 737    61     continue
 738           bilanc = max ( nbqud3, nbqud4 )
 739 c
 740 c 6.2. ==> S'il y a au moins une face inactive, precision pour le cas
 741 c          non conforme
 742 c          On autorise :
 743 c          - 1 face coupee en 4, les autres aretes non coupees
 744 c          - 1 ou 2 quadrangles coupes en 3, 1 seule arete coupee
 745 c
 746           if ( optnco.ne.0 .and. bilanc.ge.1 ) then
 747 c
 748             if ( ( nbqud3.eq.0 .and. nbqud4.eq.1 ) .or.
 749      >           ( nbqud3.le.2 .and. nbqud4.eq.0 ) ) then
 750 c
 751 #ifdef _DEBUG_HOMARD_
 752       write (ulsort,texte(langue,3)) 'UTARHE', nompro
 753 #endif
 754               call utarhe ( entite,
 755      >                      nbquto, nbhecf,
 756      >                      arequa, quahex, coquhe,
 757      >                      listar )
 758               iaux = 0
 759               do 62 , jaux = 1 , 12
 760                 if ( mod(hetare(listar(jaux)),10).ne.0 ) then
 761                   iaux = iaux + 1
 762                 endif
 763    62         continue
 764 c
 765               if ( nbqud4.eq.0 ) then
 766                 if ( iaux.eq.1 ) then
 767                   bilanc = 0
 768                 endif
 769               else
 770                 if ( iaux.eq.4 ) then
 771                   bilanc = 0
 772                 endif
 773               endif
 774 c
 775             endif
 776 c
 777           endif
 778 cgn          print *,mess14(langue,1,3), entite, ':',bilanc
 779 c
 780 c 6.3. ==> Bilan avec impression eventuelle
 781 c
 782           if ( bilanc.ne.0 ) then
 783             nbhenc = nbhenc + 1
 784             if ( optimp.ne.0 ) then
 785               write(ulsort,texte(langue,12)) mess14(langue,1,6),
 786      >                                      entite
 787               write(ulsort,texte(langue,15)) hethex(entite)
 788               do 631 , iaux = 1 , 6
 789                 lequad = quahex(entite,iaux)
 790                 write(ulsort,texte(langue,13)) mess14(langue,2,4),
 791      >                                  iaux, lequad, hetqua(lequad)
 792                 do 6311 , jaux = 1 , 4
 793                   larete = arequa(lequad,jaux)
 794                   write(ulsort,texte(langue,13))
 795      >                                    '  '//mess14(langue,2,1),
 796      >                                    jaux, larete, hetare(larete)
 797  6311           continue
 798   631         continue
 799             endif
 800           endif
 801 c
 802         endif
 803 c
 804    60 continue
 805 c
 806       if ( nbhenc.ne.0 ) then
 807         codret = 6
 808 #ifdef _DEBUG_HOMARD_
 809         if ( optimp.ne.0 ) then
 810 #else
 811         if ( ulsort.ne.0 ) then
 812 #endif
 813           if ( optnco.eq.0 ) then
 814             write(ulsort,texte(langue,11))
 815           else
 816             write(ulsort,texte(langue,9))
 817           endif
 818           write(ulsort,texte(langue,14)) mess14(langue,3,6), nbhenc
 819         endif
 820 #ifdef _DEBUG_HOMARD_
 821       else
 822         write(ulsort,texte(langue,10)) mess14(langue,3,6)
 823 #endif
 824       endif
 825 c
 826       endif
 827 c
 828 c====
 829 c 7. verification de la conformite des pentaedres
 830 c    On ne controle pas pour l'option "1 noeud pendant" car c'est pris
 831 c    en compte par les faces
 832 c====
 833 #ifdef _DEBUG_HOMARD_
 834       write (ulsort,90002) '7. verif pentaedres ; codret', codret
 835 #endif
 836 c
 837       if ( nbpeto.ne.0 .and. optnco.le.1  ) then
 838 c
 839       nbpenc = 0
 840 c
 841       do 70 , entite = 1 , nbpecf
 842 c
 843         etat = mod ( hetpen(entite) , 100 )
 844 c
 845         if ( etat.eq.0 ) then
 846 c
 847 #ifdef _DEBUG_HOMARD_
 848        write(ulsort,texte(langue,20)) mess14(langue,1,7), entite
 849 #endif
 850 c
 851 c 7.1. ==> Decompte du nombre de faces actives
 852 c
 853           nbtrd2 = 0
 854           nbtrd4 = 0
 855           do 711 , jaux = 1 , 2
 856             iaux = mod (hettri(facpen(entite,jaux)),10)
 857             if ( iaux.ge.1 .and. iaux.le.3 ) then
 858               nbtrd2 = nbtrd2 + 1
 859             elseif ( iaux.ge.4 .and. iaux.le.8 ) then
 860               nbtrd4 = nbtrd4 + 1
 861             elseif ( iaux.eq.9 ) then
 862               nbtrd4 = nbtrd4 + 2
 863             endif
 864   711     continue
 865           nbqud3 = 0
 866           nbqud4 = 0
 867           do 721 , jaux = 3, 5
 868             iaux = mod (hetqua(facpen(entite,jaux)),100)
 869             if ( iaux.eq.4 ) then
 870               nbqud4 = nbqud4 + 1
 871             elseif ( iaux.eq.99 ) then
 872               nbqud4 = nbqud4 + 2
 873             elseif ( iaux.ne.0 ) then
 874               nbqud3 = nbqud3 + 1
 875             endif
 876   721     continue
 877           bilanc = max ( nbtrd2, nbtrd4, nbqud3, nbqud4 )
 878 c
 879 c 7.2. ==> S'il y a au moins une face inactive, precision pour le cas
 880 c          non conforme
 881 c          On autorise :
 882 c          - 1 face coupee en 4, les autres aretes non coupees
 883 c          - 1 ou 2 triangles coupes en 2, 1 seule arete coupee
 884 c          - 1 ou 2 quadrangles coupes en 3, 1 seule arete coupee
 885 c          - 1 triangle coupe en 2 et 1 quadrangle coupe en 3,
 886 c            1 seule arete coupee
 887 c
 888           if ( optnco.ne.0 .and. bilanc.ge.1 ) then
 889 c
 890             if ( ( nbtrd2.eq.0 .and. nbtrd4.eq.1 .and.
 891      >             nbqud3.eq.0 .and. nbqud4.eq.0 ) .or.
 892      >           ( nbtrd2.eq.0 .and. nbtrd4.eq.0 .and.
 893      >             nbqud3.eq.0 .and. nbqud4.eq.1 ) .or.
 894      >           ( nbtrd2.le.2 .and. nbtrd4.eq.0 .and.
 895      >             nbqud3.eq.0 .and. nbqud4.eq.0 ) .or.
 896      >           ( nbtrd2.eq.0 .and. nbtrd4.eq.0 .and.
 897      >             nbqud3.le.2 .and. nbqud4.eq.0 ) .or.
 898      >           ( nbtrd2.le.1 .and. nbtrd4.eq.0 .and.
 899      >             nbqud3.eq.1 .and. nbqud4.eq.0 ) ) then
 900 c
 901 #ifdef _DEBUG_HOMARD_
 902       write (ulsort,texte(langue,3)) 'UTARPE', nompro
 903 #endif
 904               call utarpe ( entite,
 905      >                      nbquto, nbpeto,
 906      >                      arequa, facpen, cofape,
 907      >                      listar )
 908               iaux = 0
 909               do 72 , jaux = 1 , 9
 910                 if ( mod(hetare(listar(jaux)),10).ne.0 ) then
 911                   iaux = iaux + 1
 912                 endif
 913    72         continue
 914 c
 915               if ( nbtrd4.eq.0 .and. nbqud4.eq.0 ) then
 916                 if ( iaux.eq.1 ) then
 917                   bilanc = 0
 918                 endif
 919               elseif ( nbtrd4.eq.1 ) then
 920                 if ( iaux.eq.3 ) then
 921                   bilanc = 0
 922                 endif
 923               elseif ( nbqud4.eq.1 ) then
 924                 if ( iaux.eq.4 ) then
 925                   bilanc = 0
 926                 endif
 927               endif
 928 c
 929             endif
 930 c
 931           endif
 932 cgn          print *,mess14(langue,1,3), entite, ':',bilanc
 933 c
 934 c 7.3. ==> Bilan avec impression eventuelle
 935 c
 936           if ( bilanc.ne.0 ) then
 937             nbpenc = nbpenc + 1
 938             if ( optimp.ne.0 ) then
 939               write(ulsort,texte(langue,20)) mess14(langue,1,7),
 940      >                                      entite
 941               write(ulsort,texte(langue,15)) hetpen(entite)
 942               do 731 , iaux = 1 , 2
 943                 letria = facpen(entite,iaux)
 944                 write(ulsort,texte(langue,13)) mess14(langue,2,2),
 945      >                                  iaux, letria, hettri(letria)
 946                 do 7311 , jaux = 1 , 3
 947                   larete = aretri(letria,jaux)
 948                   write(ulsort,texte(langue,13))
 949      >                                    '  '//mess14(langue,2,1),
 950      >                                    jaux, larete, hetare(larete)
 951  7311           continue
 952   731         continue
 953               do 732 , iaux = 3 , 5
 954                 lequad = facpen(entite,iaux)
 955                 write(ulsort,texte(langue,13)) mess14(langue,2,4),
 956      >                                  iaux-2, lequad, hetqua(lequad)
 957                 do 7321 , jaux = 1 , 4
 958                   larete = arequa(lequad,jaux)
 959                   write(ulsort,texte(langue,13))
 960      >                                    '  '//mess14(langue,2,1),
 961      >                                    jaux, larete, hetare(larete)
 962  7321           continue
 963   732         continue
 964             endif
 965           endif
 966 c
 967         endif
 968 c
 969    70 continue
 970 c
 971       if ( nbpenc.ne.0 ) then
 972         codret = 7
 973 #ifdef _DEBUG_HOMARD_
 974         if ( optimp.ne.0 ) then
 975 #else
 976         if ( ulsort.ne.0 ) then
 977 #endif
 978           if ( optnco.eq.0 ) then
 979             write(ulsort,texte(langue,11))
 980           else
 981             write(ulsort,texte(langue,9))
 982           endif
 983           write(ulsort,texte(langue,14)) mess14(langue,3,7), nbpenc
 984         endif
 985 #ifdef _DEBUG_HOMARD_
 986       else
 987         write(ulsort,texte(langue,10)) mess14(langue,3,7)
 988 #endif
 989       endif
 990 c
 991       endif
 992 c
 993 c====
 994 c 8. la fin
 995 c====
 996 c
 997       if ( codret.ne.0 ) then
 998 c
 999 #include "envex2.h"
1000 c
1001 #ifdef _DEBUG_HOMARD_
1002         if ( ulsort.ne.0 ) then
1003 #else
1004         if ( optimp.ne.0 ) then
1005 #endif
1006 c
1007       write (ulsort,texte(langue,1)) 'Sortie', nompro
1008       write (ulsort,texte(langue,2)) codret
1009 c
1010         endif
1011 c
1012       endif
1013 c
1014 #ifdef _DEBUG_HOMARD_
1015       write (ulsort,texte(langue,1)) 'Sortie', nompro
1016       call dmflsh (iaux)
1017 #endif
1018 c
1019       end