src/tool/Utilitaire/utppqt.F

   1       subroutine utppqt ( decisi, nbfato, nbvoto, nbvofa,
   2      >                    typvol, typfac,
   3      >                    facvol, hetvol,
   4      >                    volfac, lgpype, pypefa, nupype,
   5      >                    ulsort, langue, codret )
   6 c
   7 c ______________________________________________________________________
   8 c
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  14 c aupres des huissiers de justice Simart et Lavoir a Clamart
  15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  16 c aupres des huissiers de justice
  17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c    UTilitaire - Pyramides/Pentaedres - Quadrangles/Triangles
  28 c    --           -         -            -           -
  29 c ______________________________________________________________________
  30 c
  31 c but : complete le tableau volfac et cree le tableau pypefa
  32 c       a partir du reciproque, facvol
  33 c ______________________________________________________________________
  34 c .        .     .        .                                            .
  35 c .  nom   . e/s . taille .           description                      .
  36 c .____________________________________________________________________.
  37 c . decisi . e   .   1    . pilotage des voisins des faces :           .
  38 c .        .     .        . 1 : on construit la table.                 .
  39 c .        .     .        . 2 : on construit la table et on controle   .
  40 c .        .     .        .     qu'une face n'appartient pas a plus de .
  41 c .        .     .        .     2 volumes                              .
  42 c . nbfato . e   .   1    . nombre de faces total                      .
  43 c . nbvoto . e   .   1    . nombre de volumes total                    .
  44 c . nbvofa . e   .   1    . nombre de volumes decrits par leurs faces  .
  45 c . typvol . e   .    1   . type du volume en cours d'examen           .
  46 c .        .     .        .   5 : pyramides                            .
  47 c .        .     .        .   7 : pentaedres                           .
  48 c . typfac . e   .    1   . type de la face en cours d'examen          .
  49 c .        .     .        .   2 : triangles                            .
  50 c .        .     .        .   4 : quadrangles                          .
  51 c . facvol . e   .nbvoto*5. numeros des faces des volumes              .
  52 c . hetvol . e   . nbvoto . historique de l'etat des volumes           .
  53 c . volfac . es  .2*nbfato. numeros des 2 volumes par face             .
  54 c .        .     .        . volfac(i,k) definit le i-eme voisin de k   .
  55 c .        .     .        .   0 : pas de voisin                        .
  56 c .        .     .        . j>0 : hexaedre/tetraedre j                 .
  57 c .        .     .        . j<0 : pyramide/pentaedre dans pypefa(1/2,j).
  58 c . lgpype . e   .   1    . taille du tableau pypefa                   .
  59 c . pypefa .  s  .2*lgpype. pypefa(1,j) = numero de la pyramide voisine.
  60 c .        .     .        . de la face k tel que volfac(1/2,k) = -j    .
  61 c .        .     .        . pypefa(2,j) = numero du pentaedre voisin   .
  62 c .        .     .        . de la face k tel que volfac(1/2,k) = -j    .
  63 c . nupype . es  .   1    . dernier indice cree dans le tableau pypefa .
  64 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  65 c . langue . e   .    1   . langue des messages                        .
  66 c .        .     .        . 1 : francais, 2 : anglais                  .
  67 c . codret . es  .    1   . code de retour des modules                 .
  68 c .        .     .        . 0 : pas de probleme                        .
  69 c .        .     .        . 1 : mauvais type de face                   .
  70 c .        .     .        . 2 : mauvais type de volume                 .
  71 c .        .     .        . 3 : probleme de volumes decoupees          .
  72 c ______________________________________________________________________
  73 c
  74 c====
  75 c 0. declarations et dimensionnement
  76 c====
  77 c
  78 c 0.1. ==> generalites
  79 c
  80       implicit none
  81       save
  82 c
  83       character*6 nompro
  84       parameter ( nompro = 'UTPPQT' )
  85 c
  86 #include "nblang.h"
  87 c
  88 c 0.2. ==> communs
  89 c
  90 #include "envex1.h"
  91 #include "impr02.h"
  92 c
  93 c 0.3. ==> arguments
  94 c
  95       integer decisi
  96       integer nbfato, nbvoto, nbvofa
  97       integer typvol, typfac
  98       integer hetvol(nbvoto), facvol(nbvofa,5)
  99       integer volfac(2,nbfato)
 100       integer lgpype, pypefa(2,lgpype), nupype
 101 c
 102       integer ulsort, langue, codret
 103 c
 104 c 0.4. ==> variables locales
 105 c
 106       integer iaux, jaux
 107       integer kfadeb, kfafin, nbface
 108       integer etat
 109       integer levolu, vois01, inpype, inpepy
 110       integer listfa(4)
 111       integer nbfa00, lifa00(2)
 112 #ifdef _DEBUG_HOMARD_
 113       integer typvo1, typvo2
 114       integer glop
 115       character*6 saux06(2)
 116 #endif
 117 c
 118       integer nbmess
 119       parameter ( nbmess = 10 )
 120       character*80 texte(nblang,nbmess)
 121 c
 122 c 0.5. ==> initialisations
 123 c ______________________________________________________________________
 124 c
 125 c====
 126 c 1. messages
 127 c====
 128 c
 129 #include "impr01.h"
 130 c
 131 #ifdef _DEBUG_HOMARD_
 132       write (ulsort,texte(langue,1)) 'Entree', nompro
 133       call dmflsh (iaux)
 134 #endif
 135 c
 136       texte(1,4) = '(''Voisinage '',a,''/ '',a)'
 137       texte(1,5) = '(''Le type de '',a,'',i10,'' est inconnu.'')'
 138       texte(1,6) = '(/,''Le '',a,'',i10,'' a plus de deux voisins ?'')'
 139       texte(1,7) = '(''Voisins :'',3i10,/)'
 140 c
 141       texte(2,4) = '(''Neighbourhoud '',a,''/ '',a)'
 142       texte(2,5) = '(''Type of '',a,'',i10,'' is unknown.'')'
 143       texte(2,6) = '(/,a,i10,'' has more than 2 neighbours ?'')'
 144       texte(2,7) = '(''Neighbours :'',3i10,/)'
 145 c
 146 #include "impr03.h"
 147 c
 148       codret = 0
 149 c
 150 #ifdef _DEBUG_HOMARD_
 151       write (ulsort,90002) 'typvol', typvol
 152       write (ulsort,90002) 'typfac', typfac
 153 #endif
 154 c
 155 c====
 156 c 2. Grandeurs caracteristiques
 157 c====
 158 c 2.1. ==> Pyramides
 159 c
 160       if ( typvol.eq.5 ) then
 161 c
 162         if ( typfac.eq.2 ) then
 163           kfadeb = 1
 164           kfafin = 4
 165         elseif ( typfac.eq.4 ) then
 166           kfadeb = 5
 167           kfafin = 5
 168         else
 169           codret = 1
 170         endif
 171         inpype = 1
 172         inpepy = 2
 173 c
 174 c 2.2. ==> Pentaedres
 175 c
 176       elseif ( typvol.eq.7 ) then
 177 c
 178         if ( typfac.eq.2 ) then
 179           kfadeb = 1
 180           kfafin = 2
 181         elseif ( typfac.eq.4 ) then
 182           kfadeb = 3
 183           kfafin = 5
 184         else
 185           codret = 1
 186         endif
 187         inpype = 2
 188         inpepy = 1
 189 c
 190 c 2.3. ==> Probleme
 191 c
 192       else
 193 c
 194         codret = 2
 195 c
 196       endif
 197 c
 198 c====
 199 c 3. on parcourt les volumes
 200 c====
 201 #ifdef _DEBUG_HOMARD_
 202       write (ulsort,90002) '3. parcours des volumes ; codret', codret
 203 cgn      write (ulsort,90002) 'kfadeb, kfafin = ', kfadeb, kfafin
 204 #endif
 205 c
 206       if ( codret.eq.0 ) then
 207 #ifdef _DEBUG_HOMARD_
 208       write (ulsort,texte(langue,4)) mess14(langue,1,typvol),
 209      >                               mess14(langue,1,typfac)
 210       if ( typfac.eq.2 ) then
 211         typvo1 = 3
 212         saux06(1) = 'voltri'
 213         saux06(2) = 'pypetr'
 214       else
 215         typvo1 = 6
 216         saux06(1) = 'volqua'
 217         saux06(2) = 'pypequ'
 218       endif
 219       if ( typvol.eq.5 ) then
 220         typvo2 = 7
 221       else
 222         typvo2 = 5
 223       endif
 224 #endif
 225 c
 226       nbface = kfafin - kfadeb + 1
 227 c
 228       do 30 , levolu = 1 , nbvofa
 229 #ifdef _DEBUG_HOMARD_
 230         if ( levolu.ge.-1583 ) then
 231 ccc        if ( ( typvol.eq.5 .and. typfac.eq.4 .and. levolu.lt.0 ) .or.
 232 ccc     >       ( typvol.eq.7 .and. typfac.eq.2 .and. levolu.lt.0 ) ) then
 233           glop = 1
 234         else
 235           glop = 0
 236         endif
 237 #endif
 238 c
 239 c 3.1. ==> les faces du volume en cours d'examen
 240 c
 241         do 31 , iaux = kfadeb, kfafin
 242           listfa(iaux-kfadeb+1) = facvol(levolu,iaux)
 243    31   continue
 244 c
 245 c 3.2. ==> quand le volume est decoupe par conformite, on se preoccupe
 246 c          des cas ou une face du volume se retrouve en tant que face
 247 c          d'un volume fils.
 248 c          La convention HOMARD veut que l'on ne memorise que le fils
 249 c          dans les voisins des faces.
 250 c          on va alors annuler le numero de la face pour ne rien
 251 c          archiver maintenant.
 252 c          C'est le cas dans les situations suivantes :
 253 c          . Pentaedre
 254 c             Etat | Face triangle | Face quadrangle
 255 c              1   |   2           |   4 5
 256 c              2   |   2           |   5 3
 257 c              3   |   2           |   3 4
 258 c              4   |   1           |   5 4
 259 c              5   |   1           |   3 5
 260 c              6   |   1           |   4 3
 261 c              7   |   1 2         |   5
 262 c              8   |   1 2         |   3
 263 c              9   |   1 2         |   4
 264 c             31   |   2           |
 265 c             32   |   1           |
 266 c
 267         etat = mod ( hetvol(levolu), 100 )
 268 #ifdef _DEBUG_HOMARD_
 269         if ( glop.ne.0 ) then
 270         write (ulsort,*) ' '
 271         write(ulsort,90015) mess14(langue,2,typvol), levolu,
 272      >   ', de '//mess14(langue,3,typfac), (listfa(iaux),iaux=1,nbface)
 273         write(ulsort,90002) 'Etat', etat
 274         endif
 275 #endif
 276         if ( etat.ne.0 .and. etat.ne.80 .and. etat.ne.99 ) then
 277 #ifdef _DEBUG_HOMARD_
 278           write(ulsort,*) 'Creation de ', saux06(1),'/', saux06(2)
 279 #endif
 280 c
 281           nbfa00 = 0
 282 c
 283 c 3.2.1. ==> Pentaedre et triangle
 284 c
 285           if ( typvol.eq.7 .and. typfac.eq.2 ) then
 286 c
 287             if ( ( etat.ge.1 .and. etat.le.3 ) .or. etat.eq.31 ) then
 288               nbfa00 = 1
 289               lifa00(1) = 2
 290             elseif ( ( etat.ge.4 .and. etat.le.6 ) .or.
 291      >               etat.eq.32 ) then
 292               nbfa00 = 1
 293               lifa00(1) = 1
 294             elseif ( etat.ge.7 .and. etat.le.8 ) then
 295               nbfa00 = 2
 296               lifa00(1) = 1
 297               lifa00(2) = 2
 298             endif
 299 c
 300 c 3.2.2. ==> Pentaedre et quadrangle
 301 c
 302           elseif ( typvol.eq.7 .and. typfac.eq.4 ) then
 303 c
 304             if ( etat.eq.2 .or. etat.eq.3 .or. etat.eq.5 .or.
 305      >           etat.eq.6 .or. etat.eq.8 ) then
 306               nbfa00 = nbfa00 + 1
 307               lifa00(nbfa00) = 3
 308             endif
 309             if ( etat.eq.1 .or. etat.eq.3 .or. etat.eq.4 .or.
 310      >               etat.eq.6 .or. etat.eq.9 ) then
 311               nbfa00 = nbfa00 + 1
 312               lifa00(nbfa00) = 4
 313             endif
 314             if ( etat.eq.1 .or. etat.eq.2 .or. etat.eq.4 .or.
 315      >               etat.eq.5 .or. etat.eq.7 ) then
 316               nbfa00 = nbfa00 + 1
 317               lifa00(nbfa00) = 5
 318             endif
 319 c
 320           endif
 321 c
 322 c 3.2.3. ==> Menage
 323 c
 324           do 323 , iaux = 1 , nbfa00
 325 cgn            write (ulsort,90002) 'face', facvol(levolu,lifa00(iaux))
 326             do 3231 , jaux = 1 , nbface
 327 cgn            write (ulsort,90002) '... face', listfa(jaux)
 328               if ( facvol(levolu,lifa00(iaux)).eq.listfa(jaux) ) then
 329                 listfa(jaux) = 0
 330               endif
 331  3231       continue
 332   323     continue
 333 c
 334         endif
 335 c
 336 c 3.3. ==> pour chaque face a traiter
 337 c
 338         do 33 , iaux = 1 , nbface
 339 c
 340           if ( listfa(iaux).ne.0 ) then
 341 c
 342              jaux = 0
 343              vois01 = volfac(1,listfa(iaux))
 344 #ifdef _DEBUG_HOMARD_
 345         if ( glop.ne.0 ) then
 346         write (ulsort,*) '.. ', mess14(langue,2,typfac), listfa(iaux)
 347         write (ulsort,90002) '   de voisins', vois01,
 348      >                        volfac(2,listfa(iaux))
 349         endif
 350 #endif
 351 c
 352 c 3.3.1. ==> aucun voisin n'a ete enregistre : on met le volume
 353 c            courant comme premier voisin
 354 c
 355             if ( vois01.eq.0 ) then
 356 c
 357               jaux = 1
 358 c
 359             else
 360 c
 361 c 3.3.2. ==> un premier voisin a ete enregistre : on met le volume
 362 c            courant comme second voisin
 363 c            Pour un pentaedre, trois cas de figure :
 364 c            . Si le premier voisin est un tetraedre ou un hexaedre :
 365 c              vois01>0, il faut creer un nouvel indice dans le
 366 c              tableau pypefa
 367 c            . Sinon, le premier voisin est une pyramide ou un pentaedre
 368 c              . Si le premier voisin est une pyramide, c'est-a-dire
 369 c                vois01<0 et pypefa(1,-vois01)/=0, il faut stocker
 370 c                le volume dans pypefa(2,-vois01)
 371 c              . Si le premier voisin est deja un pentaedre,
 372 c                c'est-a-dire vois01<0 et pypefa(2,-vois01)/=0, il faut
 373 c                creer un nouvel indice dans le tableau pypefa
 374 c            Pour une pyramide, le raisonnement est symetrique.
 375 c
 376 c            C'est ainsi qu'il faut stocker pour etre coherent avec
 377 c            le decodage des voisins (cf. infovo par exemple)
 378 c
 379               if ( vois01.gt.0 ) then
 380                 jaux = 2
 381 #ifdef _DEBUG_HOMARD_
 382         if ( glop.ne.0 ) then
 383       write (ulsort,*) '.... le ',mess14(langue,1,typfac), listfa(iaux),
 384      >'est deja voisin de ',mess14(langue,1,typvo1),
 385      > volfac(1,listfa(iaux))
 386         endif
 387 #endif
 388               else
 389 #ifdef _DEBUG_HOMARD_
 390         if ( glop.ne.0 ) then
 391        write (ulsort,90002) '.. '//saux06(2)//'(*,-vois01)',
 392      >          pypefa(1,-vois01), pypefa(2,-vois01)
 393         endif
 394 #endif
 395                 if ( pypefa(inpepy,-vois01).eq.0 ) then
 396                   jaux = 2
 397 #ifdef _DEBUG_HOMARD_
 398         if ( glop.ne.0 ) then
 399       write (ulsort,*) '.... le ',mess14(langue,1,typfac), listfa(iaux),
 400      > 'est voisin de ',mess14(langue,1,typvol), pypefa(inpype,-vois01)
 401         endif
 402 #endif
 403                 else
 404                   jaux = -1
 405 #ifdef _DEBUG_HOMARD_
 406         if ( glop.ne.0 ) then
 407       write (ulsort,*) '.... le ',mess14(langue,1,typfac), listfa(iaux),
 408      > 'est voisin de ',mess14(langue,1,typvo2), pypefa(inpepy,-vois01)
 409         endif
 410 #endif
 411                 endif
 412               endif
 413 c
 414 c 3.3.2.1. ==> il y a deja un second volume comme voisin de cette face !
 415 c
 416               if ( decisi.eq.2 ) then
 417 c
 418                 if ( volfac(2,listfa(iaux)).ne.0 ) then
 419 c
 420                   write(ulsort,texte(langue,6)) mess14(langue,1,typfac),
 421      >                                          listfa(iaux)
 422                   write(ulsort,texte(langue,7)) vois01,
 423      >                                          volfac(2,listfa(iaux)),
 424      >                                          levolu
 425                   codret = 3
 426 c
 427                 endif
 428 c
 429               endif
 430 c
 431             endif
 432 c
 433 c 3.3.3. ==> mise en place du voisin
 434 c            . Si jaux est > 0, on cree un nouvel indice dans pypefa et
 435 c            ce sera pour le jaux-eme voisin
 436 c            . Si jaux < 0, on complete un voisinage, donc c'est
 437 c            forcement un second voisin.
 438 #ifdef _DEBUG_HOMARD_
 439         if ( glop.ne.0 ) then
 440         write (ulsort,90002) '.... ==> jaux', jaux
 441         endif
 442 #endif
 443 c 3.3.3.1. ==> creation d'un nouvel indice du voisin
 444 c
 445             if ( jaux.gt.0 ) then
 446 c
 447 #ifdef _DEBUG_HOMARD_
 448         if ( glop.ne.0 ) then
 449         write (ulsort,90015) '.... ==> enregistrement d''un',jaux,
 450      >                   '-ieme voisin, avec nupype = ', nupype + 1
 451         endif
 452 #endif
 453               nupype = nupype + 1
 454               volfac(jaux,listfa(iaux)) = -nupype
 455               pypefa(inpype,nupype) = levolu
 456 c
 457 c 3.3.3.2. ==> complement d'un existant
 458 c
 459             elseif ( jaux.lt.0 ) then
 460 #ifdef _DEBUG_HOMARD_
 461         if ( glop.ne.0 ) then
 462         write (ulsort,90002)
 463      > '.... ==> enregistrement d''un 2-ieme voisin, avec nupype',
 464      > vois01
 465         endif
 466 #endif
 467 c
 468               volfac(2,listfa(iaux)) = vois01
 469               pypefa(inpype,-vois01) = levolu
 470 c
 471             endif
 472 c
 473           endif
 474 c
 475    33   continue
 476 c
 477    30 continue
 478 c
 479       endif
 480 c
 481 c====
 482 c 4. la fin
 483 c====
 484 c
 485       if ( codret.ne.0 ) then
 486 c
 487 #include "envex2.h"
 488 c
 489       write (ulsort,texte(langue,1)) 'Sortie', nompro
 490       write (ulsort,texte(langue,2)) codret
 491       if ( codret.le.2 ) then
 492         write (ulsort,texte(langue,5)) mess14(langue,1,7+codret), iaux
 493       endif
 494 c
 495       endif
 496 c
 497 #ifdef _DEBUG_HOMARD_
 498       write (ulsort,texte(langue,1)) 'Sortie', nompro
 499       call dmflsh (iaux)
 500 #endif
 501 c
 502       end