src/tool/Decision/debil1.F

   1       subroutine debil1 ( tyconf,
   2      >                    decfac, decare,
   3      >                    hetare,
   4      >                    hettri, aretri,
   5      >                    hetqua, arequa,
   6      >                    hethex, quahex,
   7      >                    hetpen, facpen,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c traitement des DEcisions - BILan de la conformite - 1
  30 c                --          ---                      -
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . tyconf . e   .   1    .  0 : conforme                              .
  36 c .        .     .        .  1 : non-conforme avec au minimum 2 aretes .
  37 c .        .     .        .      non decoupees en 2                    .
  38 c .        .     .        .  2 : non-conforme avec 1 seul noeud        .
  39 c .        .     .        .      pendant par arete                     .
  40 c .        .     .        .  3 : non-conforme fidele a l'indicateur    .
  41 c .        .     .        . -1 : conforme, avec des boites pour les    .
  42 c .        .     .        .      quadrangles, hexaedres et pentaedres  .
  43 c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
  44 c .        .     .        .      decoupee en 2 (boite pour les         .
  45 c .        .     .        .      quadrangles, hexaedres et pentaedres) .
  46 c .        .     .        . -2 : non-conforme avec au maximum 1 arete  .
  47 c .        .     .        .      decoupee en 2 (boite pour les         .
  48 c .        .     .        .      quadrangles, hexaedres et pentaedres) .
  49 c . decfac . es  . -nbquto. decision sur les faces (quad. + tri.)      .
  50 c .        .     . :nbtrto.                                            .
  51 c . decare . es  . nbarto . decisions des aretes                       .
  52 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  53 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  54 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  55 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  56 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  57 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  58 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  59 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  60 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  61 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  62 c . langue . e   .    1   . langue des messages                        .
  63 c .        .     .        . 1 : francais, 2 : anglais                  .
  64 c . codret . es  .    1   . code de retour des modules                 .
  65 c .        .     .        . 0 : pas de probleme                        .
  66 c .        .     .        . 1 : il existe encore des non conformites   .
  67 c ______________________________________________________________________
  68 c
  69 c====
  70 c 0. declarations et dimensionnement
  71 c====
  72 c
  73 c 0.1. ==> generalites
  74 c
  75       implicit none
  76       save
  77 c
  78       character*6 nompro
  79       parameter ( nompro = 'DEBIL1' )
  80 c
  81 #include "nblang.h"
  82 c
  83 c 0.2. ==> communs
  84 c
  85 #include "envex1.h"
  86 c
  87 #include "nombar.h"
  88 #include "nombtr.h"
  89 #include "nombqu.h"
  90 #include "nombhe.h"
  91 #include "nombpe.h"
  92 #include "impr02.h"
  93 c
  94 c 0.3. ==> arguments
  95 c
  96       integer tyconf
  97       integer decfac(-nbquto:nbtrto), decare(0:nbarto)
  98       integer hetare(nbarto)
  99       integer hettri(nbtrto), aretri(nbtrto,3)
 100       integer hetqua(nbquto), arequa(nbquto,4)
 101       integer hethex(nbheto), quahex(nbhecf,6)
 102       integer hetpen(nbpeto), facpen(nbpecf,5)
 103 c
 104       integer ulsort, langue, codret
 105 c
 106 c 0.4. ==> variables locales
 107 c
 108       integer iaux
 109       integer laface, faced, etatfa
 110       integer larelo, larete, etatar
 111       integer typenh, nbento, nbaret
 112       integer nbarpb, nbarp0, nbarp1, nbarp2, aret01
 113       integer lepent
 114       integer lehexa
 115 c
 116       integer nbmess
 117       parameter ( nbmess = 10 )
 118       character*80 texte(nblang,nbmess)
 119 c
 120 c 0.5. ==> initialisations
 121 c ______________________________________________________________________
 122 c
 123 c====
 124 c 1. messages
 125 c====
 126 c
 127 #include "impr01.h"
 128 c
 129 #ifdef _DEBUG_HOMARD_
 130       write (ulsort,texte(langue,1)) 'Entree', nompro
 131       call dmflsh (iaux)
 132 #endif
 133 c
 134       texte(1,4) = '(''Probleme avec un '',a)'
 135       texte(1,5) =
 136      > '(a,''numero '',i10,'' : decision ='',i2,'', etat ='',i5)'
 137       texte(1,6) = '(''Examen du '',a,'' numero'',i10)'
 138 c
 139       texte(2,4) = '(''Problem with a '',a)'
 140       texte(2,5) =
 141      > '(a,''#'',i10,'' : decision='',i2,'', status='',i5)'
 142       texte(2,6) = '(''Examination of the '',a,'' #'',i10)'
 143 c
 144 #include "impr03.h"
 145 c
 146 #ifdef _DEBUG_HOMARD_
 147       write (ulsort,90002) 'tyconf', tyconf
 148 #endif
 149 c
 150 c====
 151 c 2. on explore tous les faces actives a garder
 152 c    on verifie que les seules situations autorisees sont :
 153 c    pilraf = 1 ou 2 : libre
 154 c    pilraf = 3 : non-conforme avec 1 arete decoupee unique par element
 155 c                 .                      ---------------
 156 c                . .                     .             .
 157 c               .   .                    .             .
 158 c              .     .                   .             .
 159 c             .       .                  .             .
 160 c            .         .                 .             .
 161 c           .           .                .             .
 162 c           -------------                ---------------
 163 c                 .                      ---------------
 164 c                . .                     .             .
 165 c               .   .                    .             .
 166 c              .     .                   .             .
 167 c             .       .                  .             .
 168 c            .         .                 .             .
 169 c           .           .                .             .
 170 c           ------X------                --------X------
 171 c          ---------------               --------X------
 172 c          .             .               .             .
 173 c          .             .               .             .
 174 c          X             .               .             .
 175 c          .             .               .             .
 176 c          .             .               .             .
 177 c          .             .               .             .
 178 c           ------X------                --------X------
 179 c    ==> il reste au moins deux aretes non coupees
 180 c   <==> le nombre d'aretes active ou a reactiver vaut :
 181 c        . 2 ou 3 pour un triangle
 182 c        . 2, 3 ou 4 pour un quadrangle
 183 c
 184 c    pilraf = 4 : non-conforme avec 1 noeud pendant unique par arete
 185 c                 .                      ---------------
 186 c                . .                     .             .
 187 c               .   .                    .             .
 188 c              .     .                   .             .
 189 c             .       .                  .             .
 190 c            .         .                 .             .
 191 c           .           .                .             .
 192 c           -------------                ---------------
 193 c                 .                      ---------------
 194 c                . .                     .             .
 195 c               .   .                    .             .
 196 c              .     .                   .             .
 197 c             .       .                  .             .
 198 c            .         .                 .             .
 199 c           .           .                .             .
 200 c           ------X------                --------X------
 201 c
 202 c                 .                      ---------------
 203 c                . .                     .             .
 204 c               .   .                    .             .
 205 c              X     .                   X             .
 206 c             .       .                  .             .
 207 c            .         .                 .             .
 208 c           .           .                .             .
 209 c           ------X------                --------X------
 210 c
 211 c          -------X-------               -------X-------
 212 c          .             .               .             .
 213 c          .             .               .             .
 214 c          .             .               X             .
 215 c          .             .               .             .
 216 c          .             .               .             .
 217 c          .             .               .             .
 218 c          --------X------               --------X------
 219 c    ==> tout est possible, sauf toutes les aretes coupees
 220 c   <==> le nombre d'aretes active ou a reactiver vaut :
 221 c        . 1, 2 ou 3 pour un triangle
 222 c        . 1, 2, 3 ou 4 pour un quadrangle
 223 c====
 224 c
 225       codret = 0
 226       nbarp0 = 0
 227       nbarp1 = 1
 228 c
 229       do 2 , typenh = 2, 4, 2
 230 cgn        write (ulsort,*) mess14(langue,2,typenh)
 231 c
 232         if ( typenh.eq.2 ) then
 233           nbento = nbtrto
 234           nbaret = 3
 235           nbarp2 = 1
 236         else
 237           nbento = nbquto
 238           nbaret = 4
 239           if ( tyconf.lt.0 ) then
 240             nbarp2 = 2
 241           else
 242             nbarp2 = 1
 243           endif
 244        endif
 245 c
 246         do 20, laface = 1 , nbento
 247 c
 248           if ( typenh.eq.2 ) then
 249             etatfa = mod( hettri(laface) , 10 )
 250             faced = laface
 251           else
 252             etatfa = mod( hetqua(laface) , 100 )
 253             faced = -laface
 254           endif
 255 cgn          write (ulsort,1789)mess14(langue,1,typenh),
 256 cgn     > laface,etatfa,decfac(faced)
 257 cgn 1789 format(a,i6,' etat=',i4,' decision=',i2)
 258 c
 259           if ( etatfa.eq.0 ) then
 260 c
 261             if ( decfac(faced).eq.0 ) then
 262 c
 263 c 2.1. ==> on compte les aretes actives a garder et les aretes
 264 c          inactives a reactiver
 265 c
 266               nbarpb = 0
 267               aret01 = 0
 268 c
 269               do 200 , larelo = 1 , nbaret
 270                 if ( typenh.eq.2 ) then
 271                   larete = aretri(laface,larelo)
 272                 else
 273                   larete = arequa(laface,larelo)
 274                 endif
 275 cgn      write (ulsort,1789)'arete',larete,hetare(larete),decare(larete)
 276                 if ( decare(larete).eq.0 ) then
 277                   etatar = mod( hetare(larete) , 10 )
 278                   if ( etatar.eq.0 ) then
 279                     nbarpb = nbarpb + 1
 280                     if ( aret01.eq.0 ) then
 281                       aret01 = larete
 282                     endif
 283                   endif
 284                 elseif ( decare(larete).eq.-1 ) then
 285                   nbarpb = nbarpb + 1
 286                   if ( aret01.eq.0 ) then
 287                     aret01 = larete
 288                   endif
 289                 endif
 290   200         continue
 291 cgn      write (ulsort,*)'==> nbarpb = ',nbarpb
 292 c
 293 c 2.2. ==> probleme : les decisions sur les aretes sont incoherentes
 294 c                     avec les decisions sur les faces
 295 c
 296               if ( nbarpb.eq.nbarp0 .or. nbarpb.eq.nbarp1 .or.
 297      >             nbarpb.eq.nbarp2 ) then
 298 #ifdef _DEBUG_HOMARD_
 299                 write (ulsort,texte(langue,4)) mess14(langue,1,typenh)
 300                 if ( typenh.eq.2 ) then
 301                   iaux = hettri(laface)
 302                 else
 303                   iaux = hetqua(laface)
 304                 endif
 305                 write (ulsort,texte(langue,5)) mess14(langue,2,typenh),
 306      >                         laface, decfac(faced), iaux
 307                 do 220 , larelo = 1 , nbaret
 308                   if ( typenh.eq.2 ) then
 309                     larete = aretri(laface,larelo)
 310                   else
 311                     larete = arequa(laface,larelo)
 312                   endif
 313                   write (ulsort,texte(langue,5)) mess14(langue,2,1),
 314      >                         larete, decare(larete), hetare(larete)
 315   220           continue
 316 #endif
 317                 codret = 1
 318                 goto 21
 319               endif
 320 c
 321             endif
 322 c
 323           endif
 324 c
 325    20   continue
 326 c
 327     2 continue
 328 c
 329    21 continue
 330 c
 331 c====
 332 c 3. Cas des pentaedres et du raffinement libre : tant que le
 333 c    raffinement par conformite des pentaedres ne sait pas gerer les
 334 c    escaliers, il faut forcer un raffinement local par boites de
 335 c    ces pentaedres
 336 c====
 337 #ifdef _DEBUG_HOMARD_
 338       write (ulsort,90002) '3. Cas des pentaedres ; codret', codret
 339       write(ulsort,90002) 'nbpeto', nbpeto
 340 #endif
 341 c
 342       if ( ( tyconf.eq.0 ) .and. ( nbpeto.ne.0 ) ) then
 343 c
 344       do 30 , lepent = 1 , nbpeto
 345 c
 346         if ( mod(hetpen(lepent),100).eq.0 ) then
 347 c
 348 #ifdef _DEBUG_HOMARD_
 349       write (ulsort,texte(langue,6)) mess14(langue,1,7), lepent
 350 #endif
 351           do 31 , iaux = 3, 5
 352 c
 353             laface = facpen(lepent,iaux)
 354 c
 355             if ( decfac(-laface).eq.0 ) then
 356               nbarpb = 0
 357               do 311 , larelo = 1 , 4
 358                 larete = arequa(laface,larelo)
 359                 if ( decare(larete).eq.0 ) then
 360                   etatar = mod( hetare(larete) , 10 )
 361                   if ( etatar.eq.2 ) then
 362                     nbarpb = nbarpb + 1
 363                   endif
 364                 elseif ( decare(larete).eq.2 ) then
 365                   nbarpb = nbarpb + 1
 366                 endif
 367   311         continue
 368 cgn              if ( nbarpb.ne.0 ) then
 369 cgn      write (ulsort,texte(langue,6)) mess14(langue,1,7), lepent
 370 cgn      write(ulsort,90002) '.. nbarpb', nbarpb
 371 cgn                endif
 372               if ( nbarpb.eq.2 ) then
 373                 do 312 , larelo = 1 , 4
 374                   larete = arequa(laface,larelo)
 375                   if ( decare(larete).eq.0 ) then
 376                     etatar = mod( hetare(larete) , 10 )
 377                     if ( etatar.eq.0 ) then
 378                       decare(larete) = 2
 379                     endif
 380                   endif
 381   312           continue
 382                 decfac(-laface) = 4
 383                 codret = 1
 384               endif
 385 c
 386             endif
 387 c
 388    31     continue
 389 c
 390         endif
 391 c
 392    30 continue
 393 c
 394       endif
 395 c
 396 c====
 397 c 4. On ne peut pas deraffiner sur deux niveaux d'un coup en presence
 398 c    de quadrangles
 399 c====
 400 #ifdef _DEBUG_HOMARD_
 401       write (ulsort,90002) '4. deraffinement 2 coups ; codret', codret
 402 #endif
 403 c
 404 c 4.1. Cas des hexaedres
 405 c      Vu avec test_5
 406 c
 407 #ifdef _DEBUG_HOMARD_
 408       write (ulsort,90002) '4.1. Cas des hexaedres ; codret', codret
 409       write (ulsort,90002) 'nbhecf', nbhecf
 410 #endif
 411 c
 412       if ( nbhecf.ne.0 ) then
 413 c
 414       do 410 , lehexa = 1 , nbhecf
 415 c
 416         if ( mod(hethex(lehexa),100).eq.9 ) then
 417 c
 418 #ifdef _DEBUG_HOMARD_
 419       write (ulsort,texte(langue,6)) mess14(langue,1,6), lehexa
 420 #endif
 421 cgn        if  ( lehexa.eq.244 .or. lehexa.eq.344 .or.
 422 cgn     >      (lehexa.ge.1017 .and. lehexa.le.1024))then
 423 cgn        write(ulsort,90112)'hethex', lehexa, hethex(lehexa)
 424 cgn      do 241 , iaux=1,6
 425 cgn        write(ulsort,90112)' decfac', quahex(lehexa,iaux),
 426 cgn     >               decfac(-quahex(lehexa,iaux))
 427 cgn  241 continue
 428 cgn      endif
 429           do 411 , iaux = 1, 6
 430 c
 431             laface = quahex(lehexa,iaux)
 432 c
 433             if ( decfac(-laface).eq.-1 ) then
 434               do 4111 , larelo = 1 , 4
 435                 larete = arequa(laface,larelo)
 436                 if ( decare(larete).eq. -1 ) then
 437                   decare(larete) = 0
 438                 endif
 439  4111         continue
 440               decfac(-laface) = 0
 441               codret = 1
 442 c
 443             endif
 444 c
 445   411     continue
 446 c
 447         endif
 448 c
 449   410 continue
 450 c
 451       endif
 452 c
 453 c 4.2. Cas des pentaedres
 454 c
 455 #ifdef _DEBUG_HOMARD_
 456       write (ulsort,90002) '4.2. Cas des pentaedres ; codret', codret
 457       write (ulsort,90002) 'nbpecf', nbpecf
 458 #endif
 459 c
 460       if ( nbpecf.ne.0 ) then
 461 c
 462       do 420 , lepent = 1 , nbpecf
 463 c
 464         if ( mod(hetpen(lepent),100).eq.9 ) then
 465 c
 466 #ifdef _DEBUG_HOMARD_
 467       write (ulsort,texte(langue,6)) mess14(langue,1,7), lepent
 468 #endif
 469           do 421 , iaux = 3, 5
 470 c
 471             laface = facpen(lepent,iaux)
 472 c
 473             if ( decfac(-laface).eq.-1 ) then
 474               do 4211 , larelo = 1 , 4
 475                 larete = arequa(laface,larelo)
 476                 if ( decare(larete).eq. -1 ) then
 477                   decare(larete) = 0
 478                 endif
 479  4211         continue
 480               decfac(-laface) = 0
 481               codret = 1
 482 c
 483             endif
 484 c
 485   421     continue
 486 c
 487         endif
 488 c
 489   420 continue
 490 c
 491       endif
 492 c
 493 c====
 494 c 5. la fin
 495 c    en mode normal, on imprime seulement s'il y a un pb de memoire
 496 c====
 497 c
 498 #ifdef _DEBUG_HOMARD_
 499       if ( codret.ne.0 ) then
 500 #else
 501       if ( codret.ne.0 .and. codret.ne.1 ) then
 502 #endif
 503 c
 504 #include "envex2.h"
 505 c
 506       write (ulsort,texte(langue,1)) 'Sortie', nompro
 507       write (ulsort,texte(langue,2)) codret
 508 c
 509       endif
 510 c
 511 #ifdef _DEBUG_HOMARD_
 512       write (ulsort,texte(langue,1)) 'Sortie', nompro
 513       call dmflsh (iaux)
 514 #endif
 515 c
 516       end