src/tool/Utilitaire/utnc13.F

   1       subroutine utnc13 ( option,
   2      >                    nbnoct, trreca, trrecb,
   3      >                    nbnocq, qureca, qurecb,
   4      >                    arequa, filqua, perqua,
   5      >                    filare,
   6      >                    nouqua, tabaux,
   7      >                    ulsort, langue, codret )
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c    UTilitaire - Non Conformite - phase 13
  29 c    --           -   -                  --
  30 c    On change les numeros des faces concernees par les non-conformites
  31 c    . les faces recouvrantes sont mises au debut.
  32 c    . les faces recouvertes sont mises a la fin, en les regroupant
  33 c      par fratries
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . option . e   .    1   . option de l'operation de renumerotation    .
  39 c .        .     .        . 1 : on enleve des nbnocq premieres places  .
  40 c .        .     .        .     les faces recouvertes                  .
  41 c .        .     .        . 2 : on met aux nbnocq premieres places les .
  42 c .        .     .        .     faces recouvrantes                     .
  43 c .        .     .        . 3 : on regroupe par fratries les faces     .
  44 c .        .     .        .     recouvertes                            .
  45 c . nbnoct . e   .    1   . nombre de non conformites de quadrangles   .
  46 c . trreca .  s  .4*nbnoct. liste des triangles recouvrant un autre    .
  47 c . trrecb .  s  .4*nbnoct. liste des triangles recouverts par un autre.
  48 c . nbnocq . e   .    1   . nombre de non conformites de quadrangles   .
  49 c . qureca . e   .4*nbnocq. liste des quad. recouvrant un autre        .
  50 c . qurecb . e   .4*nbnocq. liste des quad. recouverts par un autre    .
  51 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  52 c . filqua . e   . nbquto . premier fils des quadrangles               .
  53 c . perqua . e   . nbquto . pere des quadrangles                       .
  54 c . filare . e   . nbarto . premiere fille des aretes                  .
  55 c . nouqua .  s  . nbquto . nouveau numero des quadrangles             .
  56 c . tabaux . a   .5*nbnocq. tableau auxiliaire                         .
  57 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  58 c . langue . e   .    1   . langue des messages                        .
  59 c .        .     .        . 1 : francais, 2 : anglais                  .
  60 c . codret . es  .    1   . code de retour des modules                 .
  61 c .        .     .        . 0 : pas de probleme                        .
  62 c ______________________________________________________________________
  63 c
  64 c====
  65 c 0. declarations et dimensionnement
  66 c====
  67 c
  68 c 0.1. ==> generalites
  69 c
  70       implicit none
  71       save
  72 c
  73       character*6 nompro
  74       parameter ( nompro = 'UTNC13' )
  75 c
  76 #include "nblang.h"
  77 c
  78 c 0.2. ==> communs
  79 c
  80 #include "envex1.h"
  81 c
  82 #include "ope1a4.h"
  83 #include "impr02.h"
  84 #include "nombar.h"
  85 #include "nombqu.h"
  86 c
  87 c 0.3. ==> arguments
  88 c
  89       integer option
  90       integer nbnoct, trreca(4*nbnoct), trrecb(4*nbnoct)
  91       integer nbnocq, qureca(4*nbnocq), qurecb(4*nbnocq)
  92       integer arequa(nbquto,4)
  93       integer filqua(nbquto), perqua(nbquto)
  94       integer filare(nbarto)
  95       integer nouqua(0:nbquto)
  96       integer tabaux(5,*)
  97 c
  98       integer ulsort, langue, codret
  99 c
 100 c 0.4. ==> variables locales
 101 c
 102       integer iaux, jaux, kaux, laux, maux
 103       integer ifin
 104       integer jauxm1
 105       integer lequa1, lequag, lequad
 106       integer lefils(4), quangl(4)
 107       integer arei, areim1
 108       integer f1ai, f2ai, f1aim1, f2aim1
 109       integer aretf(4)
 110       integer debut
 111       integer lgtab
 112 c
 113       integer nbmess
 114       parameter ( nbmess = 20 )
 115       character*80 texte(nblang,nbmess)
 116 c
 117 c 0.5. ==> initialisations
 118 c ______________________________________________________________________
 119 c
 120 c====
 121 c 1. preliminaires
 122 c====
 123 c
 124 c 1.1. ==> messages
 125 c
 126 #include "impr01.h"
 127 c
 128 #ifdef _DEBUG_HOMARD_
 129       write (ulsort,texte(langue,1)) 'Entree', nompro
 130       call dmflsh (iaux)
 131 #endif
 132 c
 133       texte(1,4) =
 134      > '(''Nombre de paquets de 4 '',a,'' non-conformes :'',i10))'
 135       texte(1,5) = '(''Decalage des quadrangles recouverts'')'
 136       texte(1,6) = '(''Renumerotation des quadrangles recouvrants'')'
 137       texte(1,7) = '(''Regroupement des quadrangles recouverts'')'
 138       texte(1,8) = '(''Examen du '',a,'' numero'',i10)'
 139       texte(1,9) = '(''.. couvert par le '',a,'' numero'',i10)'
 140       texte(1,10) = '(''.. couvrant les '',a,'' numero'',4i10)'
 141       texte(1,11) = '(''dont les '',a,'' sont :'',4i10)'
 142 c
 143       texte(2,4) =
 144      > '(''Number of packs of 4 non-conformal '',a,'' :'',i10))'
 145       texte(2,5) = '(''Shift of covered edges'')'
 146       texte(2,6) = '(''Renumbering of covering edges'')'
 147       texte(2,7) = '(''Gathering of covered edges'')'
 148       texte(2,8) = '(''Examination of '',a,'' #'',i10)'
 149       texte(2,9) = '(''.. covered by '',a,'' #'',i10)'
 150       texte(2,10) = '(''.. covering '',a,'' #'',4i10)'
 151       texte(2,11) = '(''with '',a,'' # :'',4i10)'
 152 c
 153       codret = 0
 154 c
 155 #ifdef _DEBUG_HOMARD_
 156       write (ulsort,texte(langue,4)) mess14(langue,3,2), nbnoct
 157       write (ulsort,texte(langue,4)) mess14(langue,3,4), nbnocq
 158       write (ulsort,texte(langue,4+option))
 159 #endif
 160 c
 161 c 1.2. ==> Aucune renumerotation au depart
 162 c
 163       do 12 , iaux = 0 , nbquto
 164         nouqua(iaux) = iaux
 165    12 continue
 166 c
 167 c====
 168 c 2. option numero 1 : plus aucune face recouverte ne doit se trouver
 169 c    parmi les nbnocq premieres
 170 c    On examine chacune des faces recouvertes. Si son numero
 171 c    est inferieur a nbnocq, on la permute avec une face de numero
 172 c    superieur a nbnocq et qui n'est pas une recouverte
 173 c====
 174 c
 175       if ( option.eq.1 ) then
 176 c
 177         if ( codret.eq.0 ) then
 178 c
 179         debut = nbnocq + 1
 180         ifin = 4*nbnocq
 181         do 21 , iaux = 1 , ifin
 182 c
 183           if ( codret.eq.0 ) then
 184 c
 185           lequad = qurecb(iaux)
 186 c
 187           if ( lequad.le.nbnocq ) then
 188 c
 189 #ifdef _DEBUG_HOMARD_
 190             write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad
 191 #endif
 192             do 211 , jaux = debut, nbquto
 193               if ( perqua(jaux).eq.0 ) then
 194                 kaux = jaux
 195                 goto 212
 196               endif
 197   211       continue
 198 c
 199             codret = option
 200 c
 201   212       continue
 202 c
 203             nouqua(kaux) = lequad
 204             nouqua(lequad) = kaux
 205             debut = kaux + 1
 206 cgn          write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad
 207 cgn          write (ulsort,*) lequad,' devient', kaux
 208 c
 209           endif
 210 c
 211           endif
 212 c
 213    21   continue
 214 c
 215         endif
 216 c
 217 c====
 218 c 3. option numero 2 : les faces recouvrantes sont mises aux nbnocq
 219 c    premieres places
 220 c    On examine chacune des faces recouvrantes dans la liste qureca. Si
 221 c    son numero est superieur a nbnocq, on la permute avec une face
 222 c    de numero inferieur a nbnocq et qui n'est pas une recouvrante. Il
 223 c    faut noter que chaque face apparait plusieurs fois. Il ne faut la
 224 c    permuter que la 1ere fois : cela se repere avec son nouveau numero
 225 c====
 226 c
 227       elseif ( option.eq.2 ) then
 228 c
 229         if ( codret.eq.0 ) then
 230 c
 231         debut = 1
 232         ifin = 4*nbnocq
 233         do 31 , iaux = 1 , ifin
 234 c
 235           if ( codret.eq.0 ) then
 236 c
 237           lequad = qureca(iaux)
 238 c
 239           if ( lequad.gt.nbnocq .and. nouqua(lequad).eq.lequad ) then
 240 c
 241 #ifdef _DEBUG_HOMARD_
 242             write (ulsort,texte(langue,8)) mess14(langue,1,4), lequad
 243 #endif
 244             do 311 , jaux = debut, nbnocq
 245               if ( filqua(jaux).eq.0 ) then
 246                 kaux = jaux
 247                 goto 312
 248               endif
 249   311       continue
 250 c
 251             codret = option
 252 c
 253   312       continue
 254 c
 255             nouqua(kaux) = lequad
 256             nouqua(lequad) = kaux
 257             debut = kaux + 1
 258 cgn          write (ulsort,*) lequad,' devient', kaux
 259 c
 260           endif
 261 c
 262           endif
 263 c
 264    31   continue
 265 c
 266         endif
 267 c
 268 c====
 269 c 4. option numero 3 : les faces recouvertes sont regroupees par
 270 c    fratries
 271 c====
 272 c
 273       elseif ( option.eq.3 ) then
 274 c
 275 c 4.1. ==> Regroupement des fils adoptifs et de leur pere
 276 c 4.1.1. ==> Aucun regroupement au depart
 277 c
 278         do 41 , iaux = 1 , nbnocq
 279 c
 280           tabaux(1,iaux) = 0
 281           tabaux(2,iaux) = 0
 282           tabaux(3,iaux) = 0
 283           tabaux(4,iaux) = 0
 284           tabaux(5,iaux) = 0
 285 c
 286    41   continue
 287 c
 288 c 4.1.2. ==> On regroupe les fils adoptifs et leur pere
 289 c
 290         lgtab = 0
 291         ifin = 4*nbnocq
 292         do 42 , iaux = 1 , ifin
 293 c
 294           lequa1 = qurecb(iaux)
 295           lequag = qureca(iaux)
 296 c
 297 #ifdef _DEBUG_HOMARD_
 298       write (ulsort,texte(langue,8)) mess14(langue,1,4), lequa1
 299       write (ulsort,texte(langue,9)) mess14(langue,1,4), lequag
 300 #endif
 301 c
 302 c       on cherche si on a deja place le quadrangle jumeau de lequa1
 303 c       . si oui, on place le quadrangle courant en position 3, 4 ou 5
 304 c       . si non, on place le quadrangle pere en position 1 et le fils
 305 c         en position 2
 306 c
 307           do 422 ,  jaux = 1, lgtab
 308 c
 309             if ( tabaux(1,jaux).eq.lequag ) then
 310               if ( tabaux(3,jaux).eq.0 ) then
 311                 tabaux(3,jaux) = lequa1
 312               elseif ( tabaux(4,jaux).eq.0 ) then
 313                 tabaux(4,jaux) = lequa1
 314               else
 315                 tabaux(5,jaux) = lequa1
 316               endif
 317               goto 42
 318             endif
 319 c
 320   422     continue
 321 c
 322           lgtab = lgtab + 1
 323           tabaux(1,lgtab) = lequag
 324           tabaux(2,lgtab) = lequa1
 325 c
 326    42   continue
 327 cgn      print *,'lgtab = ', lgtab
 328 c
 329 c 4.3. ==> Les quadrangles recouverts : on les place par 2 ou 4
 330 c     On cherche en partant de la fin de la numerotation 2 ou 4 places
 331 c     contigues qui ne soient pas deja des quadrangles recouverts.
 332 c          Remarque : ce ne peut pas etre des recouvrants car on les
 333 c                     a mis au debut au cours du passage option=1
 334 c
 335         debut = nbnocq + 1
 336         do 43 , iaux = 1 , lgtab
 337 c
 338           if ( codret.eq.0 ) then
 339 c
 340           lequag = tabaux(1,iaux)
 341           lefils(1) = tabaux(2,iaux)
 342           lefils(2) = tabaux(3,iaux)
 343           lefils(3) = tabaux(4,iaux)
 344           lefils(4) = tabaux(5,iaux)
 345 c
 346 #ifdef _DEBUG_HOMARD_
 347       write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(1)
 348       write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(2)
 349       write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(3)
 350       write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(4)
 351       write (ulsort,texte(langue,9)) mess14(langue,1,4), lequag
 352 #endif
 353 c
 354 c          Pour 2 fils, on ne fait rien car pas prevu aujourd'hui
 355           if ( lefils(3).eq.0 ) then
 356 c
 357       write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(1)
 358       write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(2)
 359       write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(3)
 360       write (ulsort,texte(langue,8)) mess14(langue,1,4), lefils(4)
 361       write (ulsort,texte(langue,9)) mess14(langue,1,4), lequag
 362             codret = -1
 363 c
 364           else
 365 c
 366             do 432 , jaux = debut, nbquto
 367               if ( perqua(jaux  ).eq.0 .and. perqua(jaux+1).eq.0 .and.
 368      >             perqua(jaux+2).eq.0 .and. perqua(jaux+3).eq.0 ) then
 369                 kaux = jaux
 370                 goto 433
 371               endif
 372   432       continue
 373             codret = option
 374 c
 375           endif
 376 c
 377   433     continue
 378 #ifdef _DEBUG_HOMARD_
 379       write (ulsort,*) 'kaux = ', kaux
 380 #endif
 381 c
 382 c 4.4. ==> Dans le cas de 4 fils, on doit reperer dans quel angle du
 383 c          pere se situe chacun d'eux pour respecter la convention
 384 c          de cmrdqu
 385 c
 386           if ( codret.eq.0 ) then
 387 c
 388           do 44 , jaux = 1 , 4
 389 c
 390             if ( codret.eq.0 ) then
 391 c
 392 c 4.4.1. ==> Les 2 aretes j et j-1 du pere ainsi que leurs filles
 393 c
 394             arei = arequa(lequag,jaux)
 395             f1ai = filare(arei)
 396             f2ai = f1ai + 1
 397 c
 398             jauxm1 = per1a4(-1,jaux)
 399             areim1 = arequa(lequag,jauxm1)
 400             f1aim1 = filare(areim1)
 401             f2aim1 = f1aim1 + 1
 402 c
 403 c 4.4.2. ==> Lequel des 4 quadrangles fils est dans cet angle ?
 404 c
 405             do 442 , laux = 1 , 4
 406 c
 407 c 4.4.2.1. ==> Les aretes du laux-eme fils
 408 c
 409               do 4421 , maux = 1 , 4
 410                 aretf(maux) = arequa(lefils(laux),maux)
 411  4421         continue
 412 c
 413 #ifdef _DEBUG_HOMARD_
 414             write (ulsort,texte(langue,8))
 415      >                   mess14(langue,1,4)//'fils', lefils(laux)
 416             write (ulsort,texte(langue,11)) mess14(langue,3,1),
 417      >                                     aretf
 418 #endif
 419 c
 420 c 4.4.2.2. ==> Quelle arete du laux-eme fils est fille de l'arete i ?
 421 c              Si on n'en a pas trouve, on passe au fils suivant
 422 c
 423               do 4422 , maux = 1 , 4
 424 c
 425                 if ( aretf(maux).eq.f1ai .or.
 426      >               aretf(maux).eq.f2ai ) then
 427                   goto 44221
 428                 endif
 429 c
 430  4422         continue
 431 c
 432               goto 442
 433 c
 434 44221         continue
 435 c
 436 c 4.4.2.3. ==> Quelle arete du fils est fille de l'arete i-1 ?
 437 c              Si on n'en a pas trouve, on passe au fils suivant
 438 c
 439               do 4423 , maux = 1 , 4
 440 c
 441                 if ( aretf(maux).eq.f1aim1 .or.
 442      >               aretf(maux).eq.f2aim1 ) then
 443                   goto 44231
 444                 endif
 445 c
 446  4423         continue
 447 c
 448               goto 442
 449 c
 450 44231         continue
 451 c
 452 c 4.4.2.4. ==> Si on arrive ici, c'est que le laux-eme fils est
 453 c              dans l'angle jaux
 454 c              On passe a l'angle suivant.
 455 c
 456               quangl(jaux) = lefils(laux)
 457               goto 44
 458 c
 459   442       continue
 460 c
 461 c 4.4.3. ==> Si on arrive ici, c'est qu'aucun fils n'est
 462 c            dans l'angle jaux
 463 c
 464             codret = 443
 465 c
 466             endif
 467 c
 468    44     continue
 469 cgn            write (ulsort,*) 'quangle : ',quangl
 470 c
 471           endif
 472 c
 473 c 4.5. ==> On renumerote en placant dans les angles corrects
 474 c
 475           if ( codret.eq.0 ) then
 476 c
 477           do 45 , jaux = 1 , 4
 478 c
 479 cgn            if ( kaux.eq.1501)then
 480 cgn              write(ulsort,*) 'kaux=1501 ',quangl(jaux)
 481 cgn            elseif ( quangl(jaux).eq.1501)then
 482 cgn              write(ulsort,*) 'quangl(jaux)=1501 ',kaux
 483 cgn            endif
 484             nouqua(kaux) = quangl(jaux)
 485             nouqua(quangl(jaux)) = kaux
 486 c
 487             kaux = kaux + 1
 488 c
 489    45     continue
 490 c
 491           debut = kaux
 492 c
 493           endif
 494 c
 495           endif
 496 c
 497    43   continue
 498 c
 499 c====
 500 c 5. option autre : impossible
 501 c====
 502 c
 503       else
 504 c
 505         codret = -1
 506 c
 507       endif
 508 c
 509 c====
 510 c 6. la fin
 511 c====
 512 c
 513       if ( codret.ne.0 ) then
 514 c
 515 #include "envex2.h"
 516 c
 517       write (ulsort,texte(langue,1)) 'Sortie', nompro
 518       write (ulsort,texte(langue,2)) codret
 519 c
 520       endif
 521 c
 522 #ifdef _DEBUG_HOMARD_
 523       write (ulsort,texte(langue,1)) 'Sortie', nompro
 524       call dmflsh (iaux)
 525 #endif
 526 c
 527       end