src/tool/Utilitaire/utvgva.F

   1       subroutine utvgva ( nhvois, nharet, nhtria, nhquad,
   2      >                    nhtetr, nhhexa, nhpyra, nhpent,
   3      >                    option,
   4      >                    ulsort, langue, codret )
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c     UTilitaire : VoisinaGes Volumes / Aretes
  26 c     --           -      -   -         -
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nhvois . e   . char8  . nom de l'objet voisinage                   .
  32 c . nharet . e   . char8  . nom de l'objet decrivant les aretes        .
  33 c . nhtria . e   . char8  . nom de l'objet decrivant les triangles     .
  34 c . nhquad . e   . char8  . nom de l'objet decrivant les quadrangles   .
  35 c . nhtetr . e   . char8  . nom de l'objet decrivant les tetraedres    .
  36 c . nhhexa . e   . char8  . nom de l'objet decrivant les hexaedres     .
  37 c . nhpyra . e   . char8  . nom de l'objet decrivant les pyramides     .
  38 c . nhpent . e   . char8  . nom de l'objet decrivant les pentaedres    .
  39 c . option . e   .   1    . pilotage des volumes voisins des faces :   .
  40 c .        .     .        . -1 : on detruit la table.                  .
  41 c .        .     .        . 0 : on ne fait rien.                       .
  42 c .        .     .        . 1 : on construit la table.                 .
  43 c .        .     .        . 2 : on construit la table et on controle   .
  44 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  45 c . langue . e   .    1   . langue des messages                        .
  46 c .        .     .        . 1 : francais, 2 : anglais                  .
  47 c . codret . es  .    1   . code de retour des modules                 .
  48 c .        .     .        . 0 : pas de probleme                        .
  49 c .        .     .        . non nul : probleme                         .
  50 c ______________________________________________________________________
  51 c
  52 c====
  53 c 0. declarations et dimensionnement
  54 c====
  55 c
  56 c 0.1. ==> generalites
  57 c
  58       implicit none
  59       save
  60 c
  61       character*6 nompro
  62       parameter ( nompro = 'UTVGVA' )
  63 c
  64 #include "nblang.h"
  65 c
  66 c 0.2. ==> communs
  67 c
  68 #include "envex1.h"
  69 c
  70 #include "gmenti.h"
  71 #include "impr02.h"
  72 c
  73 c 0.3. ==> arguments
  74 c
  75       character*8 nhvois, nharet, nhtria, nhquad
  76       character*8 nhtetr, nhhexa, nhpyra, nhpent
  77 c
  78       integer option
  79 c
  80       integer ulsort, langue, codret
  81 c
  82 c 0.4. ==> variables locales
  83 c
  84       integer iaux, jaux, kaux
  85       integer adaux
  86       integer codre1, codre2, codre3
  87       integer codre0
  88       integer nbarto
  89       integer nbtrto
  90       integer nbquto
  91       integer nbteto, nbtecf, nbteca
  92       integer nbheto, nbhecf, nbheca
  93       integer nbpyto, nbpycf, nbpyca
  94       integer nbpeto, nbpecf, nbpeca
  95       integer phettr, paretr
  96       integer phetqu, parequ
  97       integer phette, ptrite, pcotrt, parete
  98       integer phethe, pquahe, pcoquh, parehe
  99       integer phetpy, pfacpe, pcofay, parepy
 100       integer phetpe, pfacpy, pcofap, parepe
 101       integer adptte, adpthe, adptpy, adptpe
 102       integer adtate, adtahe, adtapy, adtape
 103       integer nbtear, nbhear, nbpyar, nbpear
 104 c
 105       character*8 saux08
 106 c
 107       integer nbmess
 108       parameter ( nbmess = 10 )
 109       character*80 texte(nblang,nbmess)
 110 c ______________________________________________________________________
 111 c
 112 c====
 113 c 1. initialisation
 114 c====
 115 c
 116 c 1.1. ==> messages
 117 c
 118 #include "impr01.h"
 119 c
 120 #ifdef _DEBUG_HOMARD_
 121       write (ulsort,texte(langue,1)) 'Entree', nompro
 122       call dmflsh (iaux)
 123 #endif
 124 c
 125       texte(1,4) = '(''Voisinage volumes-aretes.'')'
 126       texte(1,5) = '(''Demande : '',i6)'
 127       texte(1,6) = '(''Mauvaise demande.'')'
 128 c
 129       texte(2,4) = '(''Neighbourhood volumes-edges.'')'
 130       texte(2,5) = '(''Request : '',i6)'
 131       texte(2,6) = '(''Bad request.'')'
 132 c
 133 #include "impr03.h"
 134 c
 135 #ifdef _DEBUG_HOMARD_
 136       write (ulsort,texte(langue,4))
 137       write (ulsort,texte(langue,5)) option
 138 #endif
 139 c
 140       codret = 0
 141 c
 142 c====
 143 c 2. Controle de l'option
 144 c====
 145 c
 146 #ifdef _DEBUG_HOMARD_
 147       write (ulsort,*) '2. Controle option ; codret =',codret
 148 #endif
 149       if ( codret.eq.0 ) then
 150 c
 151       if ( option.lt.-1 .or. option.gt.2 ) then
 152 c
 153         write (ulsort,texte(langue,5)) option
 154         write (ulsort,texte(langue,6))
 155         codret = 2
 156 c
 157       endif
 158 c
 159       endif
 160 c
 161 c====
 162 c 3. recuperation des donnees du maillage d'entree
 163 c    remarque : on relit les nombres d'entites car les communs ne
 164 c               sont pas forcement remplis
 165 c====
 166 #ifdef _DEBUG_HOMARD_
 167       write (ulsort,*) '3. recuperation ; codret =',codret
 168 #endif
 169 c
 170       if ( option.eq.1 .or. option.eq.2 ) then
 171 c
 172 c 3.1. ==> Les tetraedres
 173 c
 174         if ( codret.eq.0 ) then
 175 c
 176         call gmliat ( nhtetr, 1, nbteto, codre1 )
 177         call gmliat ( nhtetr, 2, nbteca, codre2 )
 178 c
 179         codre0 = min ( codre1, codre2 )
 180         codret = max ( abs(codre0), codret,
 181      >                 codre1, codre2 )
 182 c
 183 #ifdef _DEBUG_HOMARD_
 184         write (ulsort,90002) 'nbteto, nbteca', nbteto, nbteca
 185 #endif
 186 c
 187         if ( nbteto.gt.0 ) then
 188 c
 189           iaux = 26
 190           if ( nbteca.gt.0 ) then
 191             iaux = iaux*31
 192           endif
 193 #ifdef _DEBUG_HOMARD_
 194           write (ulsort,texte(langue,3)) 'UTAD02_te', nompro
 195 #endif
 196           call utad02 (   iaux, nhtetr,
 197      >                  phette, ptrite,   jaux,  jaux,
 198      >                    jaux,   jaux,   jaux,
 199      >                    jaux, pcotrt,   jaux,
 200      >                    jaux,   jaux, parete,
 201      >                  ulsort, langue, codret )
 202 c
 203         endif
 204 c
 205         endif
 206 c
 207 c 3.2. ==> Les hexaedres
 208 c
 209         if ( codret.eq.0 ) then
 210 c
 211         call gmliat ( nhhexa, 1, nbheto, codre1 )
 212         call gmliat ( nhhexa, 2, nbheca, codre2 )
 213 c
 214         codre0 = min ( codre1, codre2 )
 215         codret = max ( abs(codre0), codret,
 216      >                 codre1, codre2 )
 217 c
 218 #ifdef _DEBUG_HOMARD_
 219         write (ulsort,90002) 'nbheto, nbheca', nbheto, nbheca
 220 #endif
 221 c
 222         if ( nbheto.gt.0 ) then
 223 c
 224           iaux = 26
 225           if ( nbheca.gt.0 ) then
 226             iaux = iaux*31
 227           endif
 228 #ifdef _DEBUG_HOMARD_
 229           write (ulsort,texte(langue,3)) 'UTAD02_he', nompro
 230 #endif
 231           call utad02 (   iaux, nhhexa,
 232      >                  phethe, pquahe,   jaux,  jaux,
 233      >                    jaux,   jaux,   jaux,
 234      >                    jaux, pcoquh,   jaux,
 235      >                    jaux,   jaux, parehe,
 236      >                  ulsort, langue, codret )
 237 c
 238         endif
 239 c
 240         endif
 241 c
 242 c 3.3. ==> Les pyramides
 243 c
 244         if ( codret.eq.0 ) then
 245 c
 246         call gmliat ( nhpyra, 1, nbpyto, codre1 )
 247         call gmliat ( nhpyra, 2, nbpyca, codre2 )
 248 c
 249         codre0 = min ( codre1, codre2 )
 250         codret = max ( abs(codre0), codret,
 251      >                 codre1, codre2 )
 252 c
 253 #ifdef _DEBUG_HOMARD_
 254         write (ulsort,90002) 'nbpyto, nbpyca', nbpyto, nbpyca
 255 #endif
 256 c
 257         if ( nbpyto.gt.0 ) then
 258 c
 259           iaux = 26
 260           if ( nbpyca.gt.0 ) then
 261             iaux = iaux*31
 262           endif
 263 #ifdef _DEBUG_HOMARD_
 264           write (ulsort,texte(langue,3)) 'UTAD02_py', nompro
 265 #endif
 266           call utad02 (   iaux, nhpyra,
 267      >                  phetpy, pfacpy,   jaux,  jaux,
 268      >                    jaux,   jaux,   jaux,
 269      >                    jaux, pcofay,   jaux,
 270      >                    jaux,   jaux, parepy,
 271      >                  ulsort, langue, codret )
 272 c
 273         endif
 274 c
 275         endif
 276 c
 277 c 3.4. ==> Les pentaedres
 278 c
 279         if ( codret.eq.0 ) then
 280 c
 281         call gmliat ( nhpent, 1, nbpeto, codre1 )
 282         call gmliat ( nhpent, 2, nbpeca, codre2 )
 283 c
 284         codre0 = min ( codre1, codre2 )
 285         codret = max ( abs(codre0), codret,
 286      >                 codre1, codre2 )
 287 c
 288 #ifdef _DEBUG_HOMARD_
 289         write (ulsort,90002) 'nbpeto, nbpeca', nbpeto, nbpeca
 290 #endif
 291 c
 292         if ( nbpeto.gt.0 ) then
 293 c
 294           iaux = 26
 295           if ( nbpeca.gt.0 ) then
 296             iaux = iaux*31
 297           endif
 298 #ifdef _DEBUG_HOMARD_
 299           write (ulsort,texte(langue,3)) 'UTAD02_pe', nompro
 300 #endif
 301           call utad02 (   iaux, nhpent,
 302      >                  phetpe, pfacpe,   jaux,  jaux,
 303      >                    jaux,   jaux,   jaux,
 304      >                    jaux, pcofap,   jaux,
 305      >                    jaux,   jaux, parepe,
 306      >                  ulsort, langue, codret )
 307 c
 308         endif
 309 c
 310         endif
 311 c
 312 c 3.5. ==> Bilan
 313 c
 314         if ( codret.eq.0 ) then
 315 c
 316         nbtecf = nbteto - nbteca
 317         nbhecf = nbheto - nbheca
 318         nbpycf = nbpyto - nbpyca
 319         nbpecf = nbpeto - nbpeca
 320 c
 321         endif
 322 c
 323 c 3.6. ==> Les triangles si besoin
 324 c
 325         if ( codret.eq.0 ) then
 326 c
 327         if ( nbteto.gt.0 .or. nbpycf.gt.0 ) then
 328 c
 329           call gmliat ( nhtria, 1, nbtrto, codre0 )
 330 c
 331           codret = abs(codre0)
 332 c
 333           iaux = 2
 334 #ifdef _DEBUG_HOMARD_
 335           write (ulsort,texte(langue,3)) 'UTAD02_tr', nompro
 336 #endif
 337           call utad02 (   iaux, nhtria,
 338      >                  phettr, paretr,   jaux,  jaux,
 339      >                    jaux,   jaux,   jaux,
 340      >                    jaux,   jaux,   jaux,
 341      >                    jaux,   jaux,   jaux,
 342      >                  ulsort, langue, codret )
 343 c
 344         endif
 345 c
 346         endif
 347 c
 348 c 3.7. ==> Les quadangles si besoin
 349 c
 350         if ( codret.eq.0 ) then
 351 c
 352         if ( nbheto.gt.0 .or. nbpecf.gt.0 ) then
 353 c
 354           call gmliat ( nhquad, 1, nbquto, codre0 )
 355 c
 356           codret = abs(codre0)
 357 c
 358           iaux = 2
 359 #ifdef _DEBUG_HOMARD_
 360           write (ulsort,texte(langue,3)) 'UTAD02_qu', nompro
 361 #endif
 362           call utad02 (   iaux, nhquad,
 363      >                  phetqu, parequ,   jaux,  jaux,
 364      >                    jaux,   jaux,   jaux,
 365      >                    jaux,   jaux,   jaux,
 366      >                    jaux,   jaux,   jaux,
 367      >                  ulsort, langue, codret )
 368 c
 369         endif
 370 c
 371         endif
 372 c
 373 c 3.8. ==> Nombre d'aretes
 374 c
 375         if ( codret.eq.0 ) then
 376 c
 377         call gmliat ( nharet, 1, nbarto, codre0 )
 378 c
 379         codret = abs(codre0)
 380 c
 381         endif
 382 c
 383       endif
 384 c
 385 c====
 386 c 4. Si on cree ou si on detruit, on commence par supprimer les graphes
 387 c====
 388 c
 389 #ifdef _DEBUG_HOMARD_
 390       write (ulsort,*) '4. suppression ; codret =',codret
 391 #endif
 392 c
 393       if ( option.eq.-1 .or. option.eq.1 .or. option.eq.2 ) then
 394 c
 395         do 41 , iaux = 1 , 4
 396 c
 397           if ( codret.eq.0 ) then
 398 c
 399           saux08 = '.xxx/Are'
 400           if ( iaux.eq.1 ) then
 401             saux08(2:4) = 'Tet'
 402           elseif ( iaux.eq.2 ) then
 403             saux08(2:4) = 'Hex'
 404           elseif ( iaux.eq.3 ) then
 405             saux08(2:4) = 'Pyr'
 406           else
 407             saux08(2:4) = 'Pen'
 408           endif
 409 c
 410           call gmobal ( nhvois//saux08, codre1 )
 411 c
 412           if ( codre1.eq.0 ) then
 413             codret = 0
 414 c
 415           elseif ( codre1.eq.1 ) then
 416 #ifdef _DEBUG_HOMARD_
 417       write (ulsort,*) '.... Suppression de nhvois'//saux08
 418 #endif
 419             call gmsgoj ( nhvois//saux08, codret )
 420 c
 421           else
 422             codret = 2
 423 c
 424           endif
 425 c
 426           endif
 427 c
 428    41   continue
 429 c
 430       endif
 431 c
 432 c====
 433 c 5. Creation
 434 c====
 435 c
 436 #ifdef _DEBUG_HOMARD_
 437       write (ulsort,*) '5. Creation ; codret =',codret
 438 #endif
 439 c
 440       if ( option.eq.1 .or. option.eq.2 ) then
 441 c
 442 c 5.1. ==> Allocation de la tete
 443 c
 444         do 51 , iaux = 1 , 4
 445 c
 446           if ( codret.eq.0 ) then
 447 c
 448           saux08 = '.xxx/Are'
 449           if ( iaux.eq.1 ) then
 450             saux08(2:4) = 'Tet'
 451             jaux = nbteto
 452           elseif ( iaux.eq.2 ) then
 453             saux08(2:4) = 'Hex'
 454             jaux = nbheto
 455           elseif ( iaux.eq.3 ) then
 456             saux08(2:4) = 'Pyr'
 457             jaux = nbpyto
 458           else
 459             saux08(2:4) = 'Pen'
 460             jaux = nbpeto
 461           endif
 462 c
 463           if ( jaux.gt.0 ) then
 464 #ifdef _DEBUG_HOMARD_
 465             write (ulsort,*) '.... Allocation de nhvois'//saux08
 466 #endif
 467 c
 468             call gmaloj ( nhvois//saux08 , ' ', 0, kaux, codre1 )
 469             kaux = nbarto+1
 470             call gmecat ( nhvois//saux08, 1, kaux, codre2 )
 471             call gmaloj ( nhvois//saux08//'.Pointeur',
 472      >                    ' ', kaux, adaux, codre3 )
 473 c
 474             codre0 = min ( codre1, codre2, codre3 )
 475             codret = max ( abs(codre0), codret,
 476      >                     codre1, codre2, codre3 )
 477 c
 478             if ( iaux.eq.1 ) then
 479               adptte = adaux
 480             elseif ( iaux.eq.2 ) then
 481               adpthe = adaux
 482             elseif ( iaux.eq.3 ) then
 483               adptpy = adaux
 484             else
 485               adptpe = adaux
 486             endif
 487 c
 488           endif
 489 c
 490           endif
 491 c
 492    51   continue
 493 c
 494 c 5.2. ==> Longueur des tableaux de voisinages
 495 #ifdef _DEBUG_HOMARD_
 496       write (ulsort,*) '5.2. Longueur ; codret =',codret
 497 #endif
 498 c
 499         if ( codret.eq.0 ) then
 500 c
 501 #ifdef _DEBUG_HOMARD_
 502         write (ulsort,texte(langue,3)) 'UTVGV2', nompro
 503 #endif
 504         call utvgv2 ( nbarto, nbtrto, nbquto,
 505      >                nbteto, nbtecf, nbteca,
 506      >                nbheto, nbhecf, nbheca,
 507      >                nbpyto, nbpycf, nbpyca,
 508      >                nbpeto, nbpecf, nbpeca,
 509      >                imem(paretr),
 510      >                imem(parequ),
 511      >                imem(ptrite), imem(pcotrt), imem(parete),
 512      >                imem(pquahe), imem(pcoquh), imem(parehe),
 513      >                imem(pfacpy), imem(pcofay), imem(parepy),
 514      >                imem(pfacpe), imem(pcofap), imem(parepe),
 515      >                nbtear, imem(adptte),
 516      >                nbhear, imem(adpthe),
 517      >                nbpyar, imem(adptpy),
 518      >                nbpear, imem(adptpe),
 519      >                ulsort, langue, codret )
 520 c
 521         endif
 522 c
 523 c 5.3. ==> Allocations
 524 #ifdef _DEBUG_HOMARD_
 525       write (ulsort,*) '5.3. Allocations ; codret =',codret
 526 #endif
 527 c
 528         if ( codret.eq.0 ) then
 529 c
 530         do 53 , iaux = 1 , 4
 531 c
 532           if ( codret.eq.0 ) then
 533 c
 534           saux08 = '.xxx/Are'
 535           if ( iaux.eq.1 ) then
 536             saux08(2:4) = 'Tet'
 537             jaux = nbtear
 538           elseif ( iaux.eq.2 ) then
 539             saux08(2:4) = 'Hex'
 540             jaux = nbhear
 541           elseif ( iaux.eq.3 ) then
 542             saux08(2:4) = 'Pyr'
 543             jaux = nbpyar
 544           else
 545             saux08(2:4) = 'Pen'
 546             jaux = nbpear
 547           endif
 548 c
 549           if ( jaux.gt.0 ) then
 550 #ifdef _DEBUG_HOMARD_
 551             write (ulsort,*) '.... Allocation de nhvois'//saux08
 552 #endif
 553 c
 554             call gmecat ( nhvois//saux08, 2, jaux, codre1 )
 555             call gmaloj ( nhvois//saux08//'.Table',
 556      >                    ' ', jaux, adaux, codre2 )
 557 c
 558             codre0 = min ( codre1, codre2 )
 559             codret = max ( abs(codre0), codret,
 560      >                     codre1, codre2 )
 561 c
 562             if ( iaux.eq.1 ) then
 563               adtate = adaux
 564             elseif ( iaux.eq.2 ) then
 565               adtahe = adaux
 566             elseif ( iaux.eq.3 ) then
 567               adtapy = adaux
 568             else
 569               adtape = adaux
 570             endif
 571 c
 572           endif
 573 c
 574           endif
 575 c
 576    53   continue
 577 c
 578         endif
 579 c
 580 c 5.4. ==> Determination des voisinages
 581 #ifdef _DEBUG_HOMARD_
 582       write (ulsort,*) '5.4. Determination ; codret =',codret
 583 #endif
 584 c
 585         if ( codret.eq.0 ) then
 586 c
 587 #ifdef _DEBUG_HOMARD_
 588         write (ulsort,texte(langue,3)) 'UTVGV3', nompro
 589 #endif
 590         call utvgv3 ( nbarto, nbtrto, nbquto,
 591      >                nbteto, nbtecf, nbteca,
 592      >                nbheto, nbhecf, nbheca,
 593      >                nbpyto, nbpycf, nbpyca,
 594      >                nbpeto, nbpecf, nbpeca,
 595      >                imem(paretr),
 596      >                imem(parequ),
 597      >                imem(ptrite), imem(pcotrt), imem(parete),
 598      >                imem(pquahe), imem(pcoquh), imem(parehe),
 599      >                imem(pfacpy), imem(pcofay), imem(parepy),
 600      >                imem(pfacpe), imem(pcofap), imem(parepe),
 601      >                nbtear, imem(adptte), imem(adtate),
 602      >                nbhear, imem(adpthe), imem(adtahe),
 603      >                nbpyar, imem(adptpy), imem(adtapy),
 604      >                nbpear, imem(adptpe), imem(adtape),
 605      >                ulsort, langue, codret )
 606 c
 607 #ifdef _DEBUG_HOMARD_
 608         saux08 = '.xxx/Are'
 609         if ( nbteto.gt.0 ) then
 610           saux08(2:4) = 'Tet'
 611           call gmprsx(nompro//saux08//' - pt',
 612      >                nhvois//saux08//'.Pointeur')
 613           call gmprsx(nompro//saux08//' - ta', nhvois//saux08//'.Table')
 614         endif
 615         if ( nbheto.gt.0 ) then
 616           saux08(2:4) = 'Hex'
 617           call gmprsx(nompro//saux08//' - pt',
 618      >                nhvois//saux08//'.Pointeur')
 619           call gmprsx(nompro//saux08//' - ta', nhvois//saux08//'.Table')
 620         endif
 621         if ( nbpyto.gt.0 ) then
 622           saux08(2:4) = 'Pyr'
 623           call gmprsx(nompro//saux08//' - pt',
 624      >                nhvois//saux08//'.Pointeur')
 625           call gmprsx(nompro//saux08//' - ta', nhvois//saux08//'.Table')
 626         endif
 627         if ( nbpeto.gt.0 ) then
 628           saux08(2:4) = 'Pen'
 629           call gmprsx(nompro//saux08//' - pt',
 630      >                nhvois//saux08//'.Pointeur')
 631           call gmprsx(nompro//saux08//' - ta', nhvois//saux08//'.Table')
 632         endif
 633 #endif
 634         endif
 635 c
 636       endif
 637 c
 638 c====
 639 c 6. La fin
 640 c====
 641 c
 642       if ( codret.ne.0 ) then
 643 c
 644 #include "envex2.h"
 645 c
 646       write (ulsort,texte(langue,1)) 'Sortie', nompro
 647       write (ulsort,texte(langue,2)) codret
 648 c
 649       endif
 650 c
 651 #ifdef _DEBUG_HOMARD_
 652       write (ulsort,texte(langue,1)) 'Sortie', nompro
 653       call dmflsh (iaux)
 654 #endif
 655 c
 656       end