src/tool/Decision/deini4.F

   1       subroutine deini4 ( tyconf,
   2      >                    decare, decfac,
   3      >                    hetare, filare,
   4      >                    aretri, hettri, filtri,
   5      >                    voltri, pypetr,
   6      >                    arequa, hetqua,
   7      >                    volqua,
   8      >                    tritet, quahex, facpen, facpyr,
   9      >                    tabaux,
  10      >                    ulsort, langue, codret)
  11 c ______________________________________________________________________
  12 c
  13 c                             H O M A R D
  14 c
  15 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  16 c
  17 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  18 c aupres des huissiers de justice Simart et Lavoir a Clamart
  19 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  20 c aupres des huissiers de justice
  21 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  22 c
  23 c    HOMARD est une marque deposee d'Electricite de France
  24 c
  25 c Copyright EDF 1996
  26 c Copyright EDF 1998
  27 c Copyright EDF 2002
  28 c Copyright EDF 2020
  29 c ______________________________________________________________________
  30 c
  31 c traitement des DEcisions - INitialisation de l'indicateur entier
  32 c                --          --
  33 c ______________________________________________________________________
  34 c
  35 c but : correction des decisions
  36 c ______________________________________________________________________
  37 c .        .     .        .                                            .
  38 c .  nom   . e/s . taille .           description                      .
  39 c .____________________________________________________________________.
  40 c . tyconf . e   .   1    .  0 : conforme (defaut)                     .
  41 c .        .     .        .  1 : non-conforme avec au minimum 2 aretes .
  42 c .        .     .        .      non decoupees en 2                    .
  43 c .        .     .        .  2 : non-conforme avec 1 seul noeud        .
  44 c .        .     .        .      pendant par arete                     .
  45 c .        .     .        .  3 : non-conforme fidele a l'indicateur    .
  46 c .        .     .        . -1 : conforme, avec des boites pour les    .
  47 c .        .     .        .      quadrangles, hexaedres et pentaedres  .
  48 c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
  49 c .        .     .        .      decoupee en 2 (boite pour les         .
  50 c .        .     .        .      quadrangles, hexaedres et pentaedres) .
  51 c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
  52 c .        .     .        .      decoupee en 2 (boite pour les         .
  53 c .        .     .        .      quadrangles, hexaedres et pentaedres) .
  54 c . decare . es  .0:nbarto. decisions des aretes                       .
  55 c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
  56 c .        .     . :nbtrto.                                            .
  57 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  58 c . filare . e   . nbarto . premiere fille des aretes                  .
  59 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  60 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  61 c . filtri . e   . nbtrto . premier fils des triangles                 .
  62 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  63 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  64 c .        .     .        .   0 : pas de voisin                        .
  65 c .        .     .        . j>0 : tetraedre j                          .
  66 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  67 c . pypetr . e   .2*lgpype. pypetr(1,j) = numero de la pyramide voisine.
  68 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  69 c .        .     .        . pypetr(2,j) = numero du pentaedre voisin   .
  70 c .        .     .        . du triangle k tel que voltri(1/2,k) = -j   .
  71 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  72 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  73 c . volqua . e   .2*nbquto. numeros des 2 volumes par quadrangle       .
  74 c .        .     .        . volqua(i,k) definit le i-eme voisin de k   .
  75 c .        .     .        .   0 : pas de voisin                        .
  76 c .        .     .        . j>0 : hexaedre j                           .
  77 c .        .     .        . j<0 : pyramide/pentaedre dans pypequ(1/2,j).
  78 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  79 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  80 c . facpen . e   .nbpecf*5. numeros des faces des pentaedres           .
  81 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  82 c . tabaux . a   . -nbquto. tableau auxiliaire sur les faces           .
  83 c .        .     . :nbtrto.  (quad. + tri.)                            .
  84 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  85 c . langue . e   .    1   . langue des messages                        .
  86 c .        .     .        . 1 : francais, 2 : anglais                  .
  87 c . codret . s   .    1   . code de retour des modules                 .
  88 c ______________________________________________________________________
  89 c
  90 c====
  91 c 0. declarations et dimensionnement
  92 c====
  93 c
  94 c 0.1. ==> generalites
  95 c
  96       implicit none
  97       save
  98 c
  99       character*6 nompro
 100       parameter ( nompro = 'DEINI4' )
 101 c
 102 #include "nblang.h"
 103 c
 104 c 0.2. ==> communs
 105 c
 106 #include "envex1.h"
 107 #include "nombar.h"
 108 #include "nombtr.h"
 109 #include "nombqu.h"
 110 #include "nombte.h"
 111 #include "nombhe.h"
 112 #include "nombpe.h"
 113 #include "nombpy.h"
 114 c
 115 c 0.3. ==> arguments
 116 c
 117       integer tyconf
 118       integer decare(0:nbarto), decfac(-nbquto:nbtrto)
 119       integer hetare(nbarto), filare(nbarto)
 120       integer aretri(nbtrto,3), hettri(nbtrto), filtri(nbtrto)
 121       integer voltri(2,nbtrto), pypetr(2,*)
 122       integer arequa(nbquto,4), hetqua(nbquto)
 123       integer volqua(2,nbquto)
 124       integer tritet(nbtecf,4)
 125       integer quahex(nbhecf,6)
 126       integer facpen(nbpecf,5)
 127       integer facpyr(nbpycf,5)
 128       integer tabaux(-nbquto:nbtrto)
 129 c
 130       integer ulsort, langue, codret
 131 c
 132 c 0.4. ==> variables locales
 133 c
 134       integer iaux, jaux, kaux
 135       integer lehexa, letetr, lapyra, lepent, letria, lequad, lequa0
 136       integer etat
 137       integer nbquad, iquad, liquad(11)
 138 c
 139       integer nbmess
 140       parameter (nbmess = 10 )
 141       character*80 texte(nblang,nbmess)
 142 c ______________________________________________________________________
 143 c
 144 c====
 145 c 1. initialisation
 146 c====
 147 c
 148 #include "impr01.h"
 149 c
 150 #ifdef _DEBUG_HOMARD_
 151       write (ulsort,texte(langue,1)) 'Entree', nompro
 152       call dmflsh (iaux)
 153 #endif
 154 c
 155       texte(1,4) =
 156      > '(5x,''Correction pour le mode conforme - phase'',i2)'
 157       texte(1,5) = '(5x,''Correction pour le mode non conforme'')'
 158 c
 159       texte(2,4) = '(5x,''Correction for conformal mode - phase #'',i1)'
 160       texte(2,5) = '(5x,''Correction for non conformal mode'')'
 161 c
 162 #include "impr03.h"
 163 c
 164       codret = 0
 165 c
 166 #ifdef _DEBUG_HOMARD_
 167       write (ulsort,*) 'entree de ',nompro
 168       do 1111 , iaux = 1 , nbarto
 169         if ( iaux.eq.-50 .or. iaux.eq.-51 .or.
 170      >       iaux.eq.-53 .or. iaux.eq.-57 ) then
 171           write (ulsort,90001) '.. arete e/d', iaux,
 172      >    hetare(iaux), decare(iaux)
 173         endif
 174 cgn        if ( decare(iaux).ne.0 ) then
 175 cgn          write (ulsort,90001) '.. arete e/d', iaux,
 176 cgn     >    hetare(iaux), decare(iaux)
 177 cgn        endif
 178  1111 continue
 179 #endif
 180 c
 181 c====
 182 c 2. Correction pour le mode conforme - phase 1
 183 c    A. Il est possible que l'on demande une reactivation de
 184 c       triangles ou de quadrangles alors que leurs aretes
 185 c       sont deja decoupees a 2 niveaux.
 186 c       Il faut alors annuler la demande de deraffinement.
 187 c    B. Du fait de filtrages, il est possible qu'une demande de
 188 c       raffinement sur une face soit liee a une restriction sur une
 189 c       arete.
 190 c       Il faut alors imposer le raffinement de l'arete
 191 c====
 192 #ifdef _DEBUG_HOMARD_
 193       write (ulsort,90002) '2. correction conforme 1 ; codret', codret
 194 #endif
 195 c
 196       if ( ( tyconf.eq.0 ) .or. ( tyconf.eq.-1 ) ) then
 197 c
 198         write(ulsort,texte(langue,4)) 1
 199 c
 200 c 2.1. ==> Aucune correction de deraffinement au depart
 201 c
 202         do 21 , iaux = -nbquto, nbtrto
 203           tabaux(iaux) = 0
 204    21   continue
 205 c
 206 c 2.2. ==> Corrections pour les triangles
 207 c
 208 cgn        write(ulsort,90002) 'nbtrto', nbtrto
 209         do 22 , iaux = 1, nbtrto
 210 c
 211 c 2.2.1. ==> Le triangle est a deraffiner
 212 c
 213           if ( decfac(iaux).eq.-1 ) then
 214 c
 215 c 2.2.1.1. ==> On voudrait reactiver le triangle, mais au moins une
 216 c              de ses aretes est coupee deux fois ==> impossible
 217 c
 218 cgn      write(ulsort,90015) 'Triangle',iaux,', etat',hettri(iaux)
 219             if ( mod(hetare(aretri(iaux,1)),10).gt.2 .or.
 220      >           mod(hetare(aretri(iaux,2)),10).gt.2 .or.
 221      >           mod(hetare(aretri(iaux,3)),10).gt.2 ) then
 222               tabaux(iaux) = 1
 223 cgn      write(ulsort,90002) 'Annulation reactivation du triangle',iaux
 224             endif
 225 c
 226 c 2.2.1.2. ==> Prise en compte du voisinage quand le fils central
 227 c              du triangle a une de ses aretes deja coupee : il faut
 228 c              traiter les faces des volumes qui s'appuient sur
 229 c              ce triangle fils
 230 c
 231 cgn      write(ulsort,*) 'filtri(',iaux,') :',filtri(iaux)
 232 cgn      write(ulsort,90002) 'hetare(aretri(filtri(iaux),1))',
 233 cgn     > hetare(aretri(filtri(iaux),1))
 234 cgn      write(ulsort,90002) 'hetare(aretri(filtri(iaux),1))',
 235 cgn     > hetare(aretri(filtri(iaux),1))
 236 cgn      write(ulsort,90002) 'hetare(aretri(filtri(iaux),2))',
 237 cgn     > hetare(aretri(filtri(iaux),2))
 238 cgn      write(ulsort,90002) 'hetare(aretri(filtri(iaux),3))',
 239 cgn     > hetare(aretri(filtri(iaux),3))
 240             if ( nbteto.gt.0 .or. nbpeto.gt.0 .or. nbpyto.gt.0 ) then
 241 c
 242             if ( mod(hettri(iaux),10).eq.9 .or.
 243      >           mod(hetare(aretri(filtri(iaux),1)),10).gt.0 .or.
 244      >           mod(hetare(aretri(filtri(iaux),2)),10).gt.0 .or.
 245      >           mod(hetare(aretri(filtri(iaux),3)),10).gt.0 ) then
 246 c
 247               do 2212 , jaux = 1, 2
 248 c
 249                 letetr = voltri(jaux,iaux)
 250                 if ( letetr.gt.0 ) then
 251 cgn      write(ulsort,90002) 'Tetraedre', letetr
 252                   do 22121 , kaux = 1, 4
 253                     letria = tritet(letetr,kaux)
 254                     tabaux(letria) = 1
 255 22121             continue
 256                 elseif ( letetr.lt.0 ) then
 257                   lapyra = pypetr(1,-letetr)
 258                   if ( lapyra.ne.0 ) then
 259 cgn      write(ulsort,90002) 'Pyramide', lapyra
 260                     do 22122 , kaux = 1, 4
 261                       letria = facpyr(lapyra,kaux)
 262                       tabaux(letria) = 1
 263 22122               continue
 264                     tabaux(-facpyr(lapyra,5)) = 1
 265                   endif
 266                   lepent = pypetr(2,-letetr)
 267                   if ( lepent.ne.0 ) then
 268 cgn      write(ulsort,90002) 'Pentaedre', lepent
 269                     do 22123 , kaux = 1, 2
 270                       letria = facpen(lepent,kaux)
 271                       tabaux(letria) = 1
 272 22123               continue
 273                     do 22124 , kaux = 3, 5
 274                       lequad = facpen(lepent,kaux)
 275                       tabaux(-lequad) = 1
 276 22124               continue
 277                   endif
 278                 endif
 279 c
 280  2212         continue
 281 c
 282             endif
 283 c
 284             endif
 285 c
 286 c 2.2.2. ==> Le triangle est a raffiner : toutes ses aretes
 287 c            doivent l'etre
 288 c
 289           elseif ( decfac(iaux).eq.4 ) then
 290 c
 291             do 222 , jaux = 1, 3
 292               if ( mod(hetare(aretri(iaux,jaux)),10).eq.0 ) then
 293                 decare(aretri(iaux,jaux)) = 2
 294               endif
 295   222       continue
 296 c
 297           endif
 298 c
 299    22   continue
 300 c
 301 c 2.3. ==> Corrections pour les quadrangles
 302 c
 303 cgn        write(ulsort,90002) 'nbquto', nbquto
 304         do 23 , iaux = 1, nbquto
 305 c
 306 c 2.3.1. ==> Le quadrangle est a deraffiner
 307 c
 308           if ( decfac(-iaux).eq.-1 ) then
 309 c
 310 c 2.3.1.1. ==> On voudrait reactiver le quadrangle, mais au moins une
 311 c              de ses aretes est coupee deux fois ==> impossible
 312 c
 313             if ( mod(hetare(arequa(iaux,1)),10).gt.2 .or.
 314      >           mod(hetare(arequa(iaux,2)),10).gt.2 .or.
 315      >           mod(hetare(arequa(iaux,3)),10).gt.2 .or.
 316      >           mod(hetare(arequa(iaux,4)),10).gt.2 ) then
 317               tabaux(-iaux) = 1
 318 cgn      write(ulsort,90002) 'Annulation reactivation du quadrangle',iaux
 319             endif
 320 c
 321 c 2.3.2. ==> Le quadrangle est a raffiner : toutes ses aretes
 322 c            doivent l'etre
 323 c
 324           elseif ( decfac(-iaux).eq.4 ) then
 325 c
 326             do 232 , jaux = 1, 4
 327               if ( mod(hetare(arequa(iaux,jaux)),10).eq.0 ) then
 328                 decare(arequa(iaux,jaux)) = 2
 329               endif
 330  232       continue
 331 c
 332           endif
 333 c
 334   23   continue
 335 c
 336 c 2.4. ==> Mise en place des corrections de deraffinement
 337 c
 338         do 241 , iaux = 1, nbquto
 339           if ( tabaux(-iaux).gt.0 ) then
 340 cgn      write(ulsort,90002) 'Annulation reactivation du quadrangle',iaux
 341 cgn      write(ulsort,90002) 'decare(arequa(iaux,1))',
 342 cgn     > decare(arequa(iaux,1))
 343 cgn      write(ulsort,90002) 'decare(arequa(iaux,2))',
 344 cgn     > decare(arequa(iaux,2))
 345 cgn      write(ulsort,90002) 'decare(arequa(iaux,3))',
 346 cgn     > decare(arequa(iaux,3))
 347 cgn      write(ulsort,90002) 'decare(arequa(iaux,4))',
 348 cgn     > decare(arequa(iaux,4))
 349             decfac (-iaux) = 0
 350             do 2411 , jaux = 1, 4
 351               decare(arequa(iaux,jaux)) =
 352      >                             max(0,decare(arequa(iaux,jaux)))
 353  2411       continue
 354           endif
 355   241   continue
 356 c
 357         do 242 , iaux = 1, nbtrto
 358           if ( tabaux(iaux).gt.0 ) then
 359 cgn      write(ulsort,90002) 'Annulation reactivation du triangle',iaux
 360 cgn      write(ulsort,90002) 'decare(aretri(iaux,1))',
 361 cgn     > decare(aretri(iaux,1))
 362 cgn      write(ulsort,90002) 'decare(aretri(iaux,2))',
 363 cgn     > decare(aretri(iaux,2))
 364 cgn      write(ulsort,90002) 'decare(aretri(iaux,3))',
 365 cgn     > decare(aretri(iaux,3))
 366             decfac (iaux) = 0
 367             do 2421 , jaux = 1, 3
 368               decare(aretri(iaux,jaux)) =
 369      >                             max(0,decare(aretri(iaux,jaux)))
 370  2421       continue
 371           endif
 372   242   continue
 373 c
 374       endif
 375 #ifdef _DEBUG_HOMARD_
 376       write (ulsort,*) 'apres 2 de ',nompro
 377       do 22222 , iaux = 1 , nbarto
 378         if ( iaux.eq.-50 .or. iaux.eq.-51 .or.
 379      >       iaux.eq.-53 .or. iaux.eq.-57 ) then
 380           write (ulsort,90001) '.. arete e/d', iaux,
 381      >    hetare(iaux), decare(iaux)
 382         endif
 383 22222 continue
 384 #endif
 385 c
 386 c====
 387 c 3. Correction pour le mode conforme - phase 2
 388 c    Dans le cas particulier de raffinement par des indicateurs
 389 c    aux noeuds ou aux aretes, on peut se trouver ainsi :
 390 c       Mail 1                    Mail 1
 391 c avec dec de conformite        apres suppr
 392 c sur l'arete horizontale     de la conformite
 393 c decare=2 en X
 394 c         o                        o
 395 c       . | .                    .   .
 396 c      .  |  .                  .    .
 397 c     .   |   .                .       .
 398 c    o..X.o....o              o..X.o....o
 399 c     .   |   .                .       .
 400 c      .  |  .                  .     .
 401 c       . | .                    .   .
 402 c         o                        o
 403 c
 404 c Si on ne fait rien, le triangle du haut ne sera jamais coupe car la
 405 c gestion des ecarts de niveau passe par les faces coupees. Il faut
 406 c donc s'en occuper ici. Il faut declarer a couper toutes les faces
 407 c qui contiennent cette arete.
 408 c                    o
 409 c                  .   .
 410 c                 T  T  T
 411 c                .       .
 412 c               o..X.o....o
 413 c                .       .
 414 c                 T  T  T
 415 c                  .   .
 416 c                    o
 417 c
 418 c Le traitement est similaire pour les quadrangles.
 419 c Remarque : cette configuration ne peut pas reapparaitre ensuite
 420 c
 421 c En mode "conforme par boites", tout volume contenant une arete
 422 c coupee deux fois sera decoupe en standard car les deux faces
 423 c qui contiennent l'arete l'auront ete. L'algorithme de contamination
 424 c gere cela.
 425 c En mode conforme pur, le meme raisonnement s'applique aux volumes
 426 c borde par un triangle : tetraedre ou pentaedre. En revanche, pour un
 427 c hexaedre, le decoupage des deux quadrangles partageant l'arete ne
 428 c suffira pas a enclencher le decoupage standard de l'hexaedre. Il faut
 429 c le forcer ici.
 430 c====
 431 #ifdef _DEBUG_HOMARD_
 432       write (ulsort,90002) '3. correction conforme 2 ; codret', codret
 433       write (ulsort,90002) 'tyconf', tyconf
 434 #endif
 435 c
 436       if ( ( tyconf.eq.0 ) .or. ( tyconf.eq.-1 ) ) then
 437 c
 438         write(ulsort,texte(langue,4)) 2
 439 c
 440 c 3.1. ==> Triangles
 441 c
 442 #ifdef _DEBUG_HOMARD_
 443       write (ulsort,90002) '3.1 Triangles ; codret', codret
 444 #endif
 445 c
 446         do 31 , iaux = 1, nbtrto
 447 c
 448           if ( decfac(iaux).eq.0 .and.
 449      >         mod(hettri(iaux),10).eq.0 ) then
 450 cgn        write(ulsort,90002) 'Triangle', iaux
 451 c
 452             do 311 , jaux = 1, 3
 453               kaux = aretri(iaux,jaux)
 454               if ( mod(hetare(kaux),10).ge.2 ) then
 455                 if ( decare(filare(kaux)).ge.2 ) then
 456 cgn        write(ulsort,90002) '. Arete', kaux
 457                   goto 312
 458                 elseif ( decare(filare(kaux)+1).ge.2 ) then
 459 cgn        write(ulsort,90002) '. Arete', kaux
 460                   goto 312
 461                 endif
 462               endif
 463   311       continue
 464 c
 465             goto 31
 466 c
 467   312       continue
 468 c
 469             do 313 , jaux = 1, 3
 470               kaux = aretri(iaux,jaux)
 471               if ( mod(hetare(kaux),10).eq.0 ) then
 472 cgn        write(ulsort,90002) '==> Triangle', iaux
 473 cgn        write(ulsort,90002) '==> Decoupage de l''arete', kaux
 474                 decare(kaux) = 2
 475               elseif ( mod(hetare(kaux),10).ge.2 ) then
 476 cgn        write(ulsort,90002) '==> Triangle', iaux
 477 cgn        write(ulsort,90002) '==> Decoupage de l''arete', kaux
 478                 decare(kaux) = max(0,decare(kaux))
 479               endif
 480   313       continue
 481 cgn        write(ulsort,90002) '.==> Decoupage du triangle', iaux
 482             decfac(iaux) = 4
 483 c
 484           endif
 485 c
 486    31   continue
 487 c
 488 c 3.2. ==> Quadrangles
 489 c
 490 #ifdef _DEBUG_HOMARD_
 491       write (ulsort,90002) '3.2. Quadrangles ; codret', codret
 492 #endif
 493 c
 494         do 32 , lequad = 1, nbquto
 495 c
 496 cgn        if ( lequad.eq.38 ) then
 497 cgn        write(ulsort,90002) 'Quadrangle',
 498 cgn     >  lequad,decfac(-lequad),hetqua(lequad)
 499 cgn        endif
 500           if ( decfac(-lequad).eq.0 ) then
 501 cgn            write(ulsort,90002) 'Quadrangle', lequad
 502 c
 503             do 321 , jaux = 1, 4
 504               kaux = arequa(lequad,jaux)
 505               if ( mod(hetare(kaux),10).ge.2 ) then
 506                 if ( decare(filare(kaux)).ge.2 ) then
 507 cgn        write(ulsort,90002) '. Arete', kaux
 508                   goto 33
 509                 elseif ( decare(filare(kaux)+1).ge.2 ) then
 510 cgn        write(ulsort,90002) '. Arete', kaux
 511                   goto 33
 512                 endif
 513               endif
 514   321       continue
 515 c
 516             goto 32
 517 c
 518 c 3.2.2. ==> Le quadrangle lequad est a traiter
 519 c            On lui ajoute tous les quadrangles des hexaedres voisins
 520 c
 521   33        continue
 522 c
 523             nbquad = 1
 524             liquad(1) = lequad
 525 cgn        if ( lequad.eq.-417 ) then
 526 cgn            write(ulsort,90002) 'Quadrangle', lequad
 527 cgn        endif
 528 c
 529             if ( nbheto.gt.0 ) then
 530 c
 531             do 322 , jaux = 1 , 2
 532 c
 533               lehexa = volqua(jaux,lequad)
 534 c
 535               if ( lehexa.gt.0 ) then
 536 c
 537                 do 3221 , kaux = 1 , 6
 538                   if ( quahex(lehexa,kaux).ne.lequad ) then
 539                     nbquad = nbquad + 1
 540                     liquad(nbquad) = quahex(lehexa,kaux)
 541                   endif
 542  3221           continue
 543 c
 544               endif
 545 c
 546   322       continue
 547 c
 548             endif
 549 cgn        if ( lequad.eq.-417 ) then
 550 cgn            write(ulsort,90002) 'nbquad', nbquad
 551 cgn        endif
 552 c
 553 c 3.2.3. ==> Traitement des quadrangles enregistres
 554 c
 555             do 323 , iquad = 1, nbquad
 556 c
 557               lequa0 = liquad(iquad)
 558         if ( lequad.eq.-417 ) then
 559             write(ulsort,90002) '.. lequa0', lequa0,decfac(-lequa0)
 560         endif
 561 c
 562               do 3231 , jaux = 1, 4
 563                 kaux = arequa(lequa0,jaux)
 564 cgn        if ( lequad.eq.-417 ) then
 565 cgn      write(ulsort,90002) '.... arete', kaux,hetare(kaux),decare(kaux)
 566 cgn        endif
 567                 if ( mod(hetare(kaux),10).eq.0 ) then
 568 cgn        if ( kaux.eq.50 .or. kaux.eq.51 .or.
 569 cgn     >       kaux.eq.53 .or. kaux.eq.57 ) then
 570 cgn        write(ulsort,90002) '==> Quadrangle', lequa0
 571 cgn        write(ulsort,90002) '==> Decoupage de l''arete', kaux
 572 cgn        endif
 573                   decare(kaux) = 2
 574                 elseif ( mod(hetare(kaux),10).ge.2 ) then
 575 cgn        write(ulsort,90002) '==> Quadrangle', lequa0
 576 cgn        write(ulsort,90002) '==> Decoupage de l''arete', kaux
 577                   decare(kaux) = max(0,decare(kaux))
 578                 endif
 579  3231         continue
 580 c
 581   323       continue
 582             if ( mod(hetqua(lequad),100).eq.0 ) then
 583 cgn        write(ulsort,90002) '==> Decoupage du quadrangle', lequad
 584               decfac(-lequad) = 4
 585             endif
 586 c
 587           endif
 588 c
 589    32   continue
 590 c
 591       endif
 592 #ifdef _DEBUG_HOMARD_
 593       write (ulsort,*) 'apres 3 de ',nompro
 594       do 33333 , iaux = 1 , nbarto
 595         if ( iaux.eq.-50 .or. iaux.eq.-51 .or.
 596      >       iaux.eq.-53 .or. iaux.eq.-57 ) then
 597           write (ulsort,90001) '.. arete e/d', iaux,
 598      >    hetare(iaux), decare(iaux)
 599         endif
 600 33333 continue
 601 #endif
 602 c
 603 c====
 604 c 4. Correction pour le mode non conforme
 605 c    Il est possible que l'on demande du decoupage d'aretes ou de
 606 c    triangles ou de quadrangles alors qu'ils le sont deja.
 607 c====
 608 #ifdef _DEBUG_HOMARD_
 609       write (ulsort,90002) '4. correction non conforme ; codret', codret
 610 #endif
 611 c
 612       if ( ( tyconf.gt.0 ) .or. ( tyconf.eq.-2 ) ) then
 613 c
 614         write(ulsort,texte(langue,5))
 615 c
 616         do 41 , iaux = 1, nbtrto
 617           if ( decfac (iaux).eq.4 ) then
 618             etat = mod(hettri(iaux),10)
 619             if ( etat.eq.4 .or.
 620      >           etat.eq.5 .or. etat.eq.6 .or. etat.eq.7 .or.
 621      >           etat.eq.9 ) then
 622               decfac (iaux) = 0
 623             endif
 624           endif
 625    41   continue
 626 c
 627         do 42 , iaux = 1, nbquto
 628           if ( decfac (-iaux).eq.4 ) then
 629             etat = mod(hetqua(iaux),100)
 630             if ( etat.eq.4 .or. etat.eq.99) then
 631               decfac (-iaux) = 0
 632             endif
 633           endif
 634    42   continue
 635 c
 636         do 43 , iaux = 1, nbarto
 637           if ( decare (iaux).eq.2 ) then
 638             etat = mod(hetare(iaux),10)
 639             if (etat.eq.2 .or. etat.eq.9 ) then
 640               decare (iaux) = 0
 641             endif
 642           endif
 643    43   continue
 644 c
 645       endif
 646 c
 647 cgn        do 444 , iaux = -nbquto, nbtrto
 648 cgn          if ( decfac(iaux).eq.-1 ) then
 649 cgn        write(ulsort,90002) '.Reactivation de la face', iaux
 650 cgn        endif
 651 cgn  444   continue
 652 c
 653 c====
 654 c 5. la fin
 655 c====
 656 c
 657 #ifdef _DEBUG_HOMARD_
 658       write (ulsort,*) 'sortie de ',nompro
 659       do  5555 , iaux = 1 , nbarto
 660         if ( iaux.eq.-50 .or. iaux.eq.-51 .or.
 661      >       iaux.eq.-53 .or. iaux.eq.-57 ) then
 662           write (ulsort,90001) '.. arete e/d', iaux,
 663      >    hetare(iaux), decare(iaux)
 664         endif
 665  5555 continue
 666 #endif
 667 c
 668 cgn      iaux = 8384
 669 cgn      write (ulsort,90015) 'decision triangle', iaux, ' :', decfac(iaux)
 670 cgn      write (ulsort,90015) 'decision arete', aretri(iaux,1), ' :',
 671 cgn     >                      decare(aretri(iaux,1))
 672 cgn      write (ulsort,90015) 'decision arete', aretri(iaux,2), ' :',
 673 cgn     >                      decare(aretri(iaux,2))
 674 cgn      write (ulsort,90015) 'decision arete', aretri(iaux,3), ' :',
 675 cgn     >                      decare(aretri(iaux,3))
 676 c
 677       if ( codret.ne.0 ) then
 678 c
 679 #include "envex2.h"
 680 c
 681       write (ulsort,texte(langue,1)) 'Sortie', nompro
 682       write (ulsort,texte(langue,2)) codret
 683 c
 684       endif
 685 c
 686 #ifdef _DEBUG_HOMARD_
 687       write (ulsort,texte(langue,1)) 'Sortie', nompro
 688       call dmflsh (iaux)
 689 #endif
 690 c
 691       end