src/tool/AP_Conversion/pcmar2.F

   1       subroutine pcmar2 ( hetare, filare, merare,
   2      >                    famare, posifa, facare,
   3      >                    aretri, hettri, nivtri,
   4      >                    voltri,
   5      >                    arequa, hetqua, nivqua,
   6      >                    nbanci, nbenrc,
   7      >                    arreca,
   8      >                    nparrc, arerec,
   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    aPres adaptation - Conversion de MAillage - Recollements - phase 2
  31 c     -                 -             --         -                    -
  32 c    Reperage des aretes de raccordement non conforme
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  38 c . filare . e   . nbarto . fille ainee de chaque arete                .
  39 c . merare . e   . nbarto . mere de chaque arete                       .
  40 c . famare . es  . nbarto . famille des aretes                         .
  41 c . posifa . e   .0:nbarto. pointeur sur tableau facare                .
  42 c . facare . e   . nbfaar . liste des faces contenant une arete        .
  43 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  44 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  45 c . nivtri . e   . nbtrto . niveau des triangles                       .
  46 c . voltri . e   .2*nbtrto. numeros des 2 volumes par triangle         .
  47 c .        .     .        . voltri(i,k) definit le i-eme voisin de k   .
  48 c .        .     .        .   0 : pas de voisin                        .
  49 c .        .     .        . j>0 : tetraedre j                          .
  50 c .        .     .        . j<0 : pyramide/pentaedre dans pypetr(1/2,j).
  51 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  52 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  53 c . nivqua . e   . nbquto . niveau des quadrangles                     .
  54 c . nbanci . e   .    1   . nombre de non conformites initiales        .
  55 c . nbenrc . e   .    1   . nombre d'entites par recollement unitaire  .
  56 c . arreca . e   .2*nbanci. liste des aretes recouvrant une autre      .
  57 c . nparrc .  s  .   1    . nombre de paires d'aretes a recoller       .
  58 c . arerec .  s  .2*nbarto. paires des aretes a recoller               .
  59 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  60 c . langue . e   .    1   . langue des messages                        .
  61 c .        .     .        . 1 : francais, 2 : anglais                  .
  62 c . codret . es  .    1   . code de retour des modules                 .
  63 c .        .     .        . 0 : pas de probleme                        .
  64 c .        .     .        . 1 : probleme                               .
  65 c ______________________________________________________________________
  66 c
  67 c====
  68 c 0. declarations et dimensionnement
  69 c====
  70 c
  71 c 0.1. ==> generalites
  72 c
  73       implicit none
  74       save
  75 c
  76       character*6 nompro
  77       parameter ( nompro = 'PCMAR2' )
  78 c
  79 #include "nblang.h"
  80 c
  81 c 0.2. ==> communs
  82 c
  83 #include "envex1.h"
  84 c
  85 #include "gmenti.h"
  86 c
  87 #include "nbfami.h"
  88 #include "nombar.h"
  89 #include "nombtr.h"
  90 #include "nombqu.h"
  91 #include "nombte.h"
  92 #include "impr02.h"
  93 c
  94 c 0.3. ==> arguments
  95 c
  96       integer hetare(nbarto), filare(nbarto), merare(nbarto)
  97       integer famare(nbarto)
  98       integer posifa(0:nbarto), facare(nbfaar)
  99       integer aretri(nbtrto,3), hettri(nbtrto), nivtri(nbtrto)
 100       integer voltri(2,nbtrto)
 101       integer arequa(nbquto,4), hetqua(nbquto), nivqua(nbquto)
 102       integer nbanci, nbenrc
 103       integer arreca(nbenrc*nbanci)
 104       integer nparrc
 105       integer arerec(2,nbarto)
 106 c
 107       integer ulsort, langue, codret
 108 c
 109 c 0.4. ==> variables locales
 110 c
 111       integer iaux, jaux, kaux, laux
 112       integer kdeb , kfin
 113       integer nbar2d, nbar3d
 114       integer larete, lareta
 115       integer adelre
 116 #ifdef _DEBUG_HOMARD_
 117       integer glop
 118 #endif
 119 c
 120       character*8 noelre
 121 c
 122       integer nbmess
 123       parameter ( nbmess = 30 )
 124       character*80 texte(nblang,nbmess)
 125 c
 126 c 0.5. ==> initialisations
 127 c ______________________________________________________________________
 128 c
 129 c====
 130 c 1. messages
 131 c====
 132 c
 133 #include "impr01.h"
 134 c
 135 #ifdef _DEBUG_HOMARD_
 136       write (ulsort,texte(langue,1)) 'Entree', nompro
 137       call dmflsh (iaux)
 138 #endif
 139 c
 140       texte(1,4) = '(''On ne devrait pas passer dans '',a)'
 141       texte(1,5) = '(''Examen du '',a,''numero '',i10)'
 142       texte(1,6) =
 143      > '(2x,''Nombre de paires de '',a,''a recoller :'',i10)'
 144       texte(1,8) =
 145      > '(''.. Modification de la famille du '',a,''numero '',i10)'
 146       texte(1,9) =
 147      > '(''.. Modification de l''''etat du '',a,''numero '',i10)'
 148       texte(1,10) = '(5x,''==> avant :'',i5,'', apres :'',i5)'
 149       texte(1,11) = '(''Nombre de non-conformites initiales :'',i10))'
 150       texte(1,12) = '(''. de fils :'',2i10))'
 151       texte(1,13) = '(''. Etat du '',a,''numero '',i10,'' :'',i10)'
 152       texte(1,14) = '(2x,''Apres la phase de limites de zone :'')'
 153       texte(1,15) = '(2x,''Apres les non conformites initiales :'')'
 154       texte(1,19) = '(''. Famille du '',a,''numero '',i10,'' :'',i10)'
 155       texte(1,20) = '(''Impossible d''''avoir des groupes internes'')'
 156 c
 157       texte(2,4) = '(a,'' should not be called.'')'
 158       texte(2,5) = '(''Examination of '',a,'',# '',i10)'
 159       texte(2,6) = '(2x,''Number of pairs of '',a,''to glue :'',i10)'
 160       texte(2,8) =
 161      > '(''.. Modification of the family of '',a,'',# '',i10)'
 162       texte(2,9) =
 163      > '(''.. Modification of the state of '',a,'',# '',i10)'
 164       texte(2,10) = '(5x,''==> old :'',i5,'', new :'',i5)'
 165       texte(2,11) = '(''Number of non-conformal situations :'',i10))'
 166       texte(2,12) = '(''. with sons :'',2i10))'
 167       texte(2,13) = '(''. State for '',a,''# '',i10,'' :'',i10)'
 168       texte(2,14) = '(2x,''After zone limit analysis :'')'
 169       texte(2,15) = '(2x,''After initial non conforming :'')'
 170       texte(2,19) = '(''. Family for '',a,''# '',i10,'' :'',i10)'
 171       texte(2,20) = '(''Impossible d''''avoir des groupes internes'')'
 172 c
 173 #include "impr03.h"
 174 c
 175       codret = 0
 176 c
 177       nparrc = 0
 178 c
 179 c====
 180 c 2. recherche des aretes a la limite entre deux zones de
 181 c    raffinement de niveau different, sans tenir compte du
 182 c    bord exterieur
 183 c====
 184 c
 185       if ( codret.eq.0 ) then
 186 c
 187       call gmalot ( noelre, 'entier  ', nbarto, adelre, codret )
 188 c
 189       endif
 190 c
 191       if ( codret.eq.0 ) then
 192 c
 193 #ifdef _DEBUG_HOMARD_
 194       write (ulsort,texte(langue,3)) 'UTBOAR', nompro
 195 #endif
 196       iaux = 3
 197       call utboar ( iaux,
 198      >              nbarto, nbtrto, nbquto, nbteto, nbfaar,
 199      >              hetare, filare,
 200      >              posifa, facare,
 201      >              aretri, hettri, voltri,
 202      >              arequa, hetqua,
 203      >              nbar2d, nbar3d, imem(adelre),
 204      >              ulsort, langue, codret )
 205 c
 206       endif
 207 c
 208 cgn      call gmprsx (nompro,noelre)
 209 c====
 210 c 3. examen des aretes en fonction de la limite de zone
 211 c====
 212 #ifdef _DEBUG_HOMARD_
 213       write (ulsort,90002) '3. examen des aretes ; codret', codret
 214 #endif
 215 c
 216       if ( codret.eq.0 ) then
 217 c
 218       do 31 , larete = 1 , nbarto
 219 c
 220 #ifdef _DEBUG_HOMARD_
 221         if ( larete.eq.-7 ) then
 222           glop = 1
 223         else
 224           glop = 0
 225         endif
 226 #endif
 227 #ifdef _DEBUG_HOMARD_
 228         if ( glop.ne.0 ) then
 229         write (ulsort,texte(langue,5)) mess14(langue,1,1), larete
 230         write (ulsort,90002) 'borare', imem(adelre-1+larete)
 231         endif
 232 #endif
 233 c
 234         iaux = imem(adelre-1+larete)
 235 c
 236 c 3.1. ==> L'arete est a la limite entre 2 zones de niveaux de
 237 c          raffinement differents. Si elle est active, on doit lui
 238 c          attribuer la famille supplementaire ainsi qu'a son aieule
 239 c
 240         if ( iaux.eq.1 ) then
 241 c
 242           if ( mod(hetare(larete),10).eq.0 ) then
 243 c
 244 c 3.1.1. ==> L'arete est a modifier
 245 c
 246 #ifdef _DEBUG_HOMARD_
 247         if ( glop.ne.0 ) then
 248           write (ulsort,texte(langue,8)) mess14(langue,1,1), larete
 249           write (ulsort,texte(langue,10)) famare(larete), nbfare
 250         endif
 251 #endif
 252             famare(larete) = nbfare
 253 c
 254 c 3.1.2. ==> Reperage de l'aieule qui borde 2 surfaces
 255 c          on cherche l'ascendant le plus ancien qui se trouve
 256 c          en limite de zone
 257 c
 258             lareta = merare(larete)
 259 c
 260    32       continue
 261 cgn            write(ulsort,90002) '... lareta', lareta
 262 c
 263             if ( imem(adelre-1+lareta).eq.1 ) then
 264               lareta = merare(lareta)
 265               goto 32
 266             endif
 267 cgn       write(ulsort,90112) 'famare', lareta, famare(lareta)
 268 c
 269 c 3.1.3. ==> Cet aieul doit faire partie du maillage de calcul. Pour
 270 c            cela, sa famille doit valoir la famille supplementaire et
 271 c            il doit passer actif.
 272 C          Remarque : il se peut que la famille d'une telle arete soit
 273 c                     deja la famille supplementaire. Il ne faut pas
 274 c                     filtrer la-dessus car sinon on ne mettra pas son
 275 c                     etat a 0 ; or cela est indispensable pour
 276 c                     etre detectee en tant qu'element de calcul.
 277 c
 278 #ifdef _DEBUG_HOMARD_
 279         if ( glop.ne.0 ) then
 280             write (ulsort,texte(langue,8)) mess14(langue,1,1), lareta
 281             write (ulsort,texte(langue,10)) famare(lareta), nbfare
 282         endif
 283 #endif
 284             famare(lareta) = nbfare
 285 c
 286             if ( mod(hetare(lareta),10).ne.0 ) then
 287 #ifdef _DEBUG_HOMARD_
 288         if ( glop.ne.0 ) then
 289               write (ulsort,texte(langue,9)) mess14(langue,1,1), lareta
 290               write (ulsort,texte(langue,10)) hetare(lareta), 0
 291         endif
 292 #endif
 293               hetare(lareta) = 0
 294             endif
 295 c
 296             nparrc = nparrc + 1
 297             arerec(1,nparrc) = lareta
 298             arerec(2,nparrc) = larete
 299 c
 300           endif
 301 c
 302         else
 303 c
 304 c 3.2. ==> L'arete est interne au domaine. Si elle est de la famille
 305 c          supplementaire, on doit la ramener a la famille libre
 306 c          Remarque : bug possible si des elements internes ont ete
 307 c                     mis dans des groupes au depart ...
 308 c
 309           if ( famare(larete).eq.nbfare ) then
 310 c
 311 #ifdef _DEBUG_HOMARD_
 312         if ( glop.ne.0 ) then
 313             write (ulsort,texte(langue,8)) mess14(langue,1,1), larete
 314             write (ulsort,texte(langue,10)) famare(larete), 1
 315         endif
 316 #endif
 317             famare(larete) = 1
 318 c
 319 c
 320 #ifdef _DEBUG_HOMARD_
 321           elseif ( famare(larete).ne.1 ) then
 322 c
 323             write (ulsort,texte(langue,19))
 324      >      mess14(langue,1,1), larete  , famare(larete)
 325             write (ulsort,texte(langue,20))
 326 ccc            codret = 12
 327 #endif
 328 c
 329           endif
 330 c
 331         endif
 332 c
 333    31 continue
 334 c
 335       endif
 336 c
 337 #ifdef _DEBUG_HOMARD_
 338       if ( codret.eq.0 ) then
 339       write (ulsort,texte(langue,14))
 340       write (ulsort,texte(langue,6)) mess14(langue,3,1), nparrc
 341       write (ulsort,*) ' '
 342       endif
 343 #endif
 344 c
 345 c====
 346 c 4. chaque arete de la non conformite initiale doit devenir
 347 c    un element si elle apparait
 348 c    on va s'interesser aux aretes recouvrantes qui sont
 349 c    decoupees en 2 et dont aucune des faces voisines n'est
 350 c    decoupee ; cela correspond en effet a la situation semblable
 351 c    au depart.
 352 c====
 353 #ifdef _DEBUG_HOMARD_
 354       write (ulsort,90002) '4. non conf initiale ; codret', codret
 355 #endif
 356 c
 357 #ifdef _DEBUG_HOMARD_
 358       write (ulsort,texte(langue,11)) nbanci
 359       write (ulsort,90002) 'nbenrc', nbenrc
 360 #endif
 361 c
 362       if ( nbanci.gt.0 ) then
 363 c
 364         if ( codret.eq.0 ) then
 365 c
 366         jaux = nbanci*nbenrc
 367 c
 368         do 41 , iaux = 1 , jaux
 369 c
 370           larete = arreca(iaux)
 371 c
 372 #ifdef _DEBUG_HOMARD_
 373         if ( larete.eq.12 ) then
 374           glop = 1
 375         else
 376           glop = 0
 377         endif
 378 #endif
 379 #ifdef _DEBUG_HOMARD_
 380         if ( glop.ne.0 ) then
 381         write (ulsort,texte(langue,5)) mess14(langue,1,1), larete
 382         endif
 383 #endif
 384 c
 385           if ( mod(hetare(larete),10).eq.2 ) then
 386 c
 387 #ifdef _DEBUG_HOMARD_
 388         if ( glop.ne.0 ) then
 389         write (ulsort,texte(langue,12)) filare(larete), filare(larete)+1
 390         write (ulsort,texte(langue,13))
 391      >  mess14(langue,1,1), filare(larete)  , hetare(filare(larete))
 392         write (ulsort,texte(langue,13))
 393      >  mess14(langue,1,1), filare(larete)+1, hetare(filare(larete)+1)
 394         endif
 395 #endif
 396 c
 397 c 4.1. ==> Si on a deja traite cette arete, on passe a la suite
 398 c
 399             do 411 , kaux = nparrc, 1, -1
 400 c
 401               if ( arerec(1,kaux).eq.larete .or.
 402      >             arerec(2,kaux).eq.larete ) then
 403                 goto 41
 404               endif
 405 c
 406   411       continue
 407 c
 408 c 4.2. ==> Si une de ses faces voisines est decoupee, on passe
 409 c            a la suite
 410 c
 411             kdeb = posifa(larete-1)+1
 412             kfin = posifa(larete)
 413             do 412 , kaux = kdeb , kfin
 414 c
 415               laux = facare(kaux)
 416               if ( laux.gt.0 ) then
 417 #ifdef _DEBUG_HOMARD_
 418         if ( glop.ne.0 ) then
 419         write (ulsort,texte(langue,5)) mess14(langue,1,2), laux
 420         write (ulsort,texte(langue,13))
 421      >  mess14(langue,1,2), laux, hettri(laux)
 422         endif
 423 #endif
 424                 if ( mod(hettri(laux),10).ne.0 ) then
 425                   goto 41
 426                 endif
 427               else
 428                 laux = -laux
 429 #ifdef _DEBUG_HOMARD_
 430         if ( glop.ne.0 ) then
 431         write (ulsort,texte(langue,5)) mess14(langue,1,4), laux
 432         write (ulsort,texte(langue,13))
 433      >  mess14(langue,1,4), laux, hetqua(laux)
 434         endif
 435 #endif
 436                 if ( mod(hetqua(laux),100).ne.0 ) then
 437                   goto 41
 438                 endif
 439               endif
 440 c
 441 c
 442   412       continue
 443 c
 444 c 4.3. ==> L'arete mere est a modifier
 445 c
 446 #ifdef _DEBUG_HOMARD_
 447          if ( glop.ne.0 ) then
 448            write (ulsort,texte(langue,8)) mess14(langue,1,1), larete
 449             write (ulsort,texte(langue,10)) famare(larete), nbfare
 450             write (ulsort,texte(langue,10)) hetare(larete), 0
 451         endif
 452 #endif
 453 c
 454             famare(larete) = nbfare
 455             hetare(larete) = 0
 456 c
 457 c 4.4. ==> Ses filles sont a modifier
 458 c
 459             do 414 , lareta = filare(larete), filare(larete)+1
 460 c
 461               if ( famare(lareta).ne.nbfare ) then
 462 c
 463 #ifdef _DEBUG_HOMARD_
 464          if ( glop.ne.0 ) then
 465             write (ulsort,texte(langue,8)) mess14(langue,1,1), lareta
 466             write (ulsort,texte(langue,10)) famare(lareta), nbfare
 467         endif
 468 #endif
 469                 famare(lareta) = nbfare
 470 c
 471                 if ( mod(hetare(lareta),10).ne.0 ) then
 472 #ifdef _DEBUG_HOMARD_
 473          if ( glop.ne.0 ) then
 474               write (ulsort,texte(langue,9)) mess14(langue,1,1), lareta
 475               write (ulsort,texte(langue,10)) hetare(lareta), 0
 476         endif
 477 #endif
 478                   hetare(lareta) = 0
 479                 endif
 480 c
 481               endif
 482 c
 483               nparrc = nparrc + 1
 484               arerec(1,nparrc) = lareta
 485               arerec(2,nparrc) = larete
 486 c
 487   414       continue
 488 c
 489           endif
 490 c
 491    41   continue
 492 c
 493         endif
 494 c
 495       endif
 496 c
 497 #ifdef _DEBUG_HOMARD_
 498       if ( codret.eq.0 ) then
 499       write (ulsort,texte(langue,15))
 500       write (ulsort,texte(langue,6)) mess14(langue,3,1), nparrc
 501       write (ulsort,*) ' '
 502       endif
 503 #endif
 504 c
 505 c====
 506 c 5. Bilan
 507 c====
 508 #ifdef _DEBUG_HOMARD_
 509       write (ulsort,90002) '5. Bilan ; codret', codret
 510 #endif
 511 c
 512       if ( codret.eq.0 ) then
 513 c
 514       call gmlboj ( noelre, codret )
 515 c
 516       endif
 517 c
 518 c====
 519 c 6. la fin
 520 c====
 521 c
 522       if ( codret.ne.0 ) then
 523 c
 524 #include "envex2.h"
 525 c
 526       write (ulsort,texte(langue,1)) 'Sortie', nompro
 527       write (ulsort,texte(langue,2)) codret
 528 c
 529       endif
 530 c
 531 #ifdef _DEBUG_HOMARD_
 532       write (ulsort,texte(langue,1)) 'Sortie', nompro
 533       call dmflsh (iaux)
 534 #endif
 535 c
 536       end