src/tool/Utilitaire/utb19a.F

   1       subroutine utb19a ( choix,
   2      >                    coonoe, somare,
   3      >                    hettri, aretri,
   4      >                    famtri, cfatri,
   5      >                    hetqua, arequa,
   6      >                    famqua, cfaqua,
   7      >                    tritet, cotrte, aretet, hettet,
   8      >                    quahex, coquhe, arehex, hethex,
   9      >                    facpyr, cofapy, arepyr, hetpyr,
  10      >                    facpen, cofape, arepen, hetpen,
  11      >                    nbiter,
  12      >                    tbiau1, tabaur,
  13      >                    ulbila,
  14      >                    ulsort, langue, codret )
  15 c ______________________________________________________________________
  16 c
  17 c                             H O M A R D
  18 c
  19 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  20 c
  21 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  22 c aupres des huissiers de justice Simart et Lavoir a Clamart
  23 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  24 c aupres des huissiers de justice
  25 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  26 c
  27 c    HOMARD est une marque deposee d'Electricite de France
  28 c
  29 c Copyright EDF 1996
  30 c Copyright EDF 1998
  31 c Copyright EDF 2002
  32 c Copyright EDF 2020
  33 c ______________________________________________________________________
  34 c
  35 c    UTilitaire - Bilan - option 19 - etape a
  36 c    --           -              --         -
  37 c  remarque : utb05a et utb19a sont des clones
  38 c ______________________________________________________________________
  39 c
  40 c but : controle des diametres des mailles
  41 c ______________________________________________________________________
  42 c .        .     .        .                                            .
  43 c .  nom   . e/s . taille .           description                      .
  44 c .____________________________________________________________________.
  45 c . choix  . e   .   1    . choix du traitement                        .
  46 c .        .     .        . 0 : creation et affichage des histogrammes .
  47 c .        .     .        . 2 : sortie du diametre des triangles       .
  48 c .        .     .        . 3 : sortie du diametre des tetraedres      .
  49 c .        .     .        . 4 : sortie du diametre des quadrangles     .
  50 c .        .     .        . 5 : sortie du diametre des pyramides       .
  51 c .        .     .        . 6 : sortie du diametre des hexaedres       .
  52 c .        .     .        . 7 : sortie du diametre des pentaedres      .
  53 c . coonoe . e   . nbnoto . coordonnees des noeuds                     .
  54 c .        .     . * sdim .                                            .
  55 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  56 c . hettri . e   . nbtrto . historique de l'etat des triangles         .
  57 c . aretri . e   .nbtrto*3. numeros des 3 aretes des triangles         .
  58 c . famtri . e   . nbtrto . famille des triangles                      .
  59 c . cfatri . e   . nctftr*. codes des familles des triangles           .
  60 c .        .     . nbftri .   1 : famille MED                          .
  61 c .        .     .        .   2 : type de triangle                     .
  62 c .        .     .        .   3 : numero de surface de frontiere       .
  63 c .        .     .        .   4 : famille des aretes internes apres raf.
  64 c .        .     .        . + l : appartenance a l'equivalence l       .
  65 c . hetqua . e   . nbquto . historique de l'etat des quadrangles       .
  66 c . arequa . e   .nbquto*4. numeros des 4 aretes des quadrangles       .
  67 c . famqua . e   . nbquto . famille des quadrangles                    .
  68 c . cfaqua . e   . nctfqu*. codes des familles des quadrangles         .
  69 c .        .     . nbfqua .   1 : famille MED                          .
  70 c .        .     .        .   2 : type de quadrangle                   .
  71 c .        .     .        .   3 : numero de surface de frontiere       .
  72 c .        .     .        .   4 : famille des aretes internes apres raf.
  73 c .        .     .        .   5 : famille des triangles de conformite  .
  74 c .        .     .        .   6 : famille de sf active/inactive        .
  75 c .        .     .        . + l : appartenance a l'equivalence l       .
  76 c . hettet . e   . nbteto . historique de l'etat des tetraedres        .
  77 c . tritet . e   .nbtecf*4. numeros des 4 triangles des tetraedres     .
  78 c . cotrte . e   .nbtecf*4. code des 4 triangles des tetraedres        .
  79 c . aretet . e   .nbteca*6. numeros des 6 aretes des tetraedres        .
  80 c . hethex . e   . nbheto . historique de l'etat des hexaedres         .
  81 c . quahex . e   .nbhecf*6. numeros des 6 quadrangles des hexaedres    .
  82 c . coquhe . e   .nbhecf*6. codes des 6 quadrangles des hexaedres      .
  83 c . arehex . e   .nbheca12. numeros des 12 aretes des hexaedres        .
  84 c . hetpyr . e   . nbpyto . historique de l'etat des pyramides         .
  85 c . facpyr . e   .nbpycf*5. numeros des 5 faces des pyramides          .
  86 c . cofapy . e   .nbpycf*5. codes des faces des pyramides              .
  87 c . arepyr . e   .nbpyca*8. numeros des 8 aretes des pyramides         .
  88 c . hetpen . e   . nbpeto . historique de l'etat des pentaedres        .
  89 c . facpen . e   .nbpecf*5. numeros des 5 faces des pentaedres         .
  90 c . cofape . e   .nbpecf*5. code des 5 faces des pentaedres            .
  91 c . arepen . e   .nbpeca*9. numeros des 9 aretes des pentaedres        .
  92 c . tbiau1 .  a  .    *   . liste des entites examinees                .
  93 c . tabaur .  a  .    *   . qualite des entites                        .
  94 c . nbiter . e   .   1    . numero de l'iteration courante             .
  95 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  96 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  97 c . langue . e   .    1   . langue des messages                        .
  98 c .        .     .        . 1 : francais, 2 : anglais                  .
  99 c . codret .  s  .    1   . code de retour des modules                 .
 100 c .        .     .        . 0 : pas de probleme                        .
 101 c .        .     .        . 1 : probleme                               .
 102 c .____________________________________________________________________.
 103 c
 104 c====
 105 c 0. declarations et dimensionnement
 106 c====
 107 c
 108 c 0.1. ==> generalites
 109 c
 110       implicit none
 111       save
 112 c
 113       character*6 nompro
 114       parameter ( nompro = 'UTB19A' )
 115 c
 116 #include "nblang.h"
 117 #include "coftex.h"
 118 c
 119 c 0.2. ==> communs
 120 c
 121 #include "envex1.h"
 122 c
 123 #include "dicfen.h"
 124 #include "nbfami.h"
 125 #include "nombno.h"
 126 #include "nombar.h"
 127 #include "nombtr.h"
 128 #include "nombqu.h"
 129 #include "nombte.h"
 130 #include "nombhe.h"
 131 #include "nombpy.h"
 132 #include "nombpe.h"
 133 #include "envca1.h"
 134 #include "impr02.h"
 135 c
 136 c 0.3. ==> arguments
 137 c
 138       double precision coonoe(nbnoto,sdim)
 139       double precision tabaur(*)
 140 c
 141       integer choix
 142 c
 143       integer somare(2,nbarto)
 144       integer hettri(nbtrto), aretri(nbtrto,3)
 145       integer cfatri(nctftr,nbftri), famtri(nbtrto)
 146       integer hetqua(nbquto), arequa(nbquto,4)
 147       integer cfaqua(nctfqu,nbfqua), famqua(nbquto)
 148       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 149       integer hettet(nbteto)
 150       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 151       integer hethex(nbheto)
 152       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 153       integer hetpyr(nbpyto)
 154       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 155       integer hetpen(nbpeto)
 156       integer tbiau1(*)
 157       integer nbiter
 158 c
 159       integer ulbila
 160       integer ulsort, langue, codret
 161 c
 162 c 0.4. ==> variables locales
 163 c
 164       integer letria, lequad
 165       integer iaux, jaux
 166       integer nbvoto
 167       integer nbeexa
 168       integer nbqinf
 169       integer tbiau2(1)
 170 c
 171       double precision daux
 172       double precision tbdaux(1)
 173 c
 174       integer nbmess
 175       parameter (nbmess = 10 )
 176       character*80 texte(nblang,nbmess)
 177 c
 178 c 0.5. ==> initialisations
 179 c ______________________________________________________________________
 180 c
 181 c====
 182 c 1. titre
 183 c====
 184 c
 185 #include "impr01.h"
 186 c
 187 #ifdef _DEBUG_HOMARD_
 188       write (ulsort,texte(langue,1)) 'Entree', nompro
 189       call dmflsh (iaux)
 190 #endif
 191 c
 192       texte(1,4) =
 193      > '(//,3x,''DIAMETRES DES MAILLES'',/,3x,21(''=''))'
 194       texte(1,5) = '(''Diametre '',a,'' des '',a,'' : '',g12.5)'
 195       texte(1,6) = '(''Nombre de '',a,'' a examiner : '',i8)'
 196 c
 197       texte(2,4) =
 198      > '(//,3x,''DIAMETERS OF MESHES'',/,3x,19(''=''))'
 199       texte(2,5) = '(''Diameter '',a,'' of '',a,'': '',g12.5)'
 200       texte(2,6) = '(''Number of '',a,'' to be examined: '',i8)'
 201 c
 202       write (ulsort,texte(langue,4))
 203       write (ulbila,texte(langue,4))
 204 c
 205       codret = 0
 206 c
 207       nbvoto = nbteto + nbpyto + nbheto + nbpeto
 208 c
 209       nbqinf = 0
 210 c
 211 c====
 212 c 2. calcul des diametres des tetraedres
 213 c===
 214 c
 215       if ( choix.eq.0 .or. choix.eq.3 ) then
 216 c
 217         if ( nbteto.ne.0 ) then
 218 c
 219           iaux = 3
 220 c
 221 #ifdef _DEBUG_HOMARD_
 222       write (ulsort,texte(langue,3)) 'UTB19C_te', nompro
 223 #endif
 224           call utb19c ( choix, iaux, nbteto, nbtecf, nbteca,
 225      >                  coonoe, somare,
 226      >                  aretri, arequa,
 227      >                  hettet, tritet, cotrte, aretet,
 228      >                  nbiter, tabaur,
 229      >                  ulbila,
 230      >                  ulsort, langue, codret )
 231 c
 232         endif
 233 c
 234       endif
 235 c
 236 c====
 237 c 3. calcul des diametres des pyramides
 238 c===
 239 #ifdef _DEBUG_HOMARD_
 240       write (ulsort,*) '3. pyramides ; codret = ', codret
 241 #endif
 242 c
 243       if ( codret.eq.0 ) then
 244 c
 245       if ( choix.eq.0 .or. choix.eq.5 ) then
 246 c
 247         if ( nbpyto.ne.0 ) then
 248 c
 249           iaux = 5
 250 c
 251 #ifdef _DEBUG_HOMARD_
 252       write (ulsort,texte(langue,3)) 'UTB19C_py', nompro
 253 #endif
 254           call utb19c ( choix, iaux, nbpyto, nbpycf, nbpyca,
 255      >                  coonoe, somare,
 256      >                  aretri, arequa,
 257      >                  hetpyr, facpyr, cofapy, arepyr,
 258      >                  nbiter, tabaur,
 259      >                  ulbila,
 260      >                  ulsort, langue, codret )
 261 c
 262         endif
 263 c
 264       endif
 265 c
 266       endif
 267 c
 268 c====
 269 c 4. calcul des diametres des hexaedres
 270 c===
 271 #ifdef _DEBUG_HOMARD_
 272       write (ulsort,*) '4. hexaedres ; codret = ', codret
 273 #endif
 274 c
 275       if ( codret.eq.0 ) then
 276 c
 277       if ( choix.eq.0 .or. choix.eq.6 ) then
 278 c
 279         if ( nbheto.ne.0 ) then
 280 c
 281           iaux = 6
 282 c
 283 #ifdef _DEBUG_HOMARD_
 284       write (ulsort,texte(langue,3)) 'UTB19C_he', nompro
 285 #endif
 286           call utb19c ( choix, iaux, nbheto, nbhecf, nbheca,
 287      >                  coonoe, somare,
 288      >                  aretri, arequa,
 289      >                  hethex, quahex, coquhe, arehex,
 290      >                  nbiter, tabaur,
 291      >                  ulbila,
 292      >                  ulsort, langue, codret )
 293 c
 294         endif
 295 c
 296       endif
 297 c
 298       endif
 299 c
 300 c====
 301 c 5. calcul des diametres des pentaedres
 302 c===
 303 #ifdef _DEBUG_HOMARD_
 304       write (ulsort,*) '5. pentaedres ; codret = ', codret
 305 #endif
 306 c
 307       if ( codret.eq.0 ) then
 308 c
 309       if ( choix.eq.0 .or. choix.eq.7 ) then
 310 c
 311         if ( nbpeto.ne.0 ) then
 312 c
 313           iaux = 7
 314 c
 315 #ifdef _DEBUG_HOMARD_
 316       write (ulsort,texte(langue,3)) 'UTB19C_pe', nompro
 317 #endif
 318           call utb19c ( choix, iaux, nbpeto, nbpecf, nbpeca,
 319      >                  coonoe, somare,
 320      >                  aretri, arequa,
 321      >                  hetpen, facpen, cofape, arepen,
 322      >                  nbiter, tabaur,
 323      >                  ulbila,
 324      >                  ulsort, langue, codret )
 325 c
 326         endif
 327 c
 328       endif
 329 c
 330       endif
 331 c
 332 c====
 333 c 6. calcul des diametres des triangles d'un maillage 2d ou 2,5d
 334 c====
 335 #ifdef _DEBUG_HOMARD_
 336       write (ulsort,*) '6. triangles ; codret = ', codret
 337 #endif
 338 c
 339       if ( codret.eq.0 ) then
 340 c
 341       if ( choix.eq.0 .or. choix.eq.2 ) then
 342 c
 343       if ( nbtrto.ne.0 ) then
 344 c
 345 c 6.1. ==> liste des triangles a examiner :
 346 c       . en l'absence de tetraedre, pentaedre et pyramide, ce sont
 347 c         tous les triangles actifs ;
 348 c       . en presence de tetraedre, pentaedre ou pyramide, ce sont les
 349 c         triangles actifs qui sont des elements de calcul
 350 c
 351       nbeexa = 0
 352 c
 353       if ( nbteto.eq.0 .and. nbpeto.eq.0 .and. nbpyto.eq.0 ) then
 354 c
 355         do 611 , letria = 1 , nbtrto
 356           if ( mod(hettri(letria),10).eq.0 ) then
 357             nbeexa = nbeexa + 1
 358             tbiau1(nbeexa) = letria
 359           endif
 360   611   continue
 361 c
 362       else
 363 c
 364         do 612 , letria = 1 , nbtrto
 365           if ( mod(hettri(letria),10).eq.0 .and.
 366      >         cfatri(cotyel,famtri(letria)).ne.0 ) then
 367             nbeexa = nbeexa + 1
 368             tbiau1(nbeexa) = letria
 369           endif
 370   612   continue
 371 c
 372       endif
 373 c
 374 #ifdef _DEBUG_HOMARD_
 375       write (ulsort,texte(langue,6)) mess14(langue,3,2), nbeexa
 376 #endif
 377 c
 378 c 6.2. ==> calcul
 379 #ifdef _DEBUG_HOMARD_
 380       write (ulsort,*) '6.2. calcul ; codret = ', codret
 381 #endif
 382 c
 383       if ( nbeexa.gt.0 ) then
 384 c
 385       do 62 , iaux = 1 , nbeexa
 386 c
 387         letria = tbiau1(iaux)
 388 c
 389         call utdtri ( letria, daux,
 390      >                coonoe, somare, aretri )
 391 c
 392         tabaur(iaux) = daux
 393 c
 394    62 continue
 395 c
 396       endif
 397 c
 398 c 6.3. ==> impression sur la sortie standard et sur un fichier
 399 c          a exploiter par xmgrace
 400 c
 401       if ( choix.eq.0 ) then
 402 c
 403         if ( nbeexa.gt.0 ) then
 404 c
 405           jaux = 0
 406           iaux = 2
 407 c
 408 #ifdef _DEBUG_HOMARD_
 409           write (ulsort,texte(langue,3)) 'UTB05B', nompro
 410 #endif
 411           call utb05b ( jaux, iaux, nbeexa, tabaur, tbdaux,
 412      >                  nbiter, rafdef, nbvoto,
 413      >                  tbiau2,
 414      >                  ulbila,
 415      >                  ulsort, langue, codret )
 416 c
 417           endif
 418 c
 419         endif
 420 c
 421       endif
 422 c
 423       endif
 424 c
 425       endif
 426 c
 427 c====
 428 c 7. calcul des diametres des quadrangles d'un maillage 2d ou 2,5d
 429 c====
 430 #ifdef _DEBUG_HOMARD_
 431       write (ulsort,*) '7. quadrangles ; codret = ', codret
 432 #endif
 433 c
 434       if ( codret.eq.0 ) then
 435 c
 436       if ( choix.eq.0 .or. choix.eq.4 ) then
 437 c
 438       if ( nbquto.ne.0 ) then
 439 c
 440 c 7.1. ==> liste des quadrangles a examiner :
 441 c       . en l'absence d'hexaedre, pentaedre et pyramide, ce sont
 442 c         tous les quadrangles actifs ;
 443 c       . en presence d'hexaedre, pentaedre ou pyramide, ce sont les
 444 c         quadrangles actifs qui sont des elements de calcul
 445 c
 446       nbeexa = 0
 447 c
 448       if ( nbheto.eq.0 .and. nbpeto.eq.0 .and. nbpyto.eq.0 ) then
 449 c
 450         do 711 , lequad = 1 , nbquto
 451           if ( mod(hetqua(lequad),100).eq.0 ) then
 452             nbeexa = nbeexa + 1
 453             tbiau1(nbeexa) = lequad
 454           endif
 455   711   continue
 456 c
 457       else
 458 c
 459         do 712 , lequad = 1 , nbquto
 460           if ( mod(hetqua(lequad),100).eq.0 .and.
 461      >         cfaqua(cotyel,famqua(lequad)).ne.0 ) then
 462             nbeexa = nbeexa + 1
 463             tbiau1(nbeexa) = lequad
 464           endif
 465   712   continue
 466 c
 467       endif
 468 c
 469 #ifdef _DEBUG_HOMARD_
 470       write (ulsort,texte(langue,6)) mess14(langue,3,4), nbeexa
 471 #endif
 472 c
 473 c 7.2. ==> calcul
 474 #ifdef _DEBUG_HOMARD_
 475       write (ulsort,*) '7.2. calcul ; codret = ', codret
 476 #endif
 477 c
 478       if ( nbeexa.gt.0 ) then
 479 c
 480       do 72 , iaux = 1 , nbeexa
 481 c
 482         lequad = tbiau1(iaux)
 483 c
 484         call utdqua ( lequad, daux,
 485      >                coonoe, somare, arequa )
 486 c
 487         tabaur(iaux) = daux
 488 c
 489    72 continue
 490 c
 491       endif
 492 c
 493 c 7.3. ==> impression sur la sortie standard et sur un fichier
 494 c          a exploiter par xmgrace
 495 c
 496       if ( choix.eq.0 ) then
 497 c
 498         if ( nbeexa.gt.0 ) then
 499 c
 500           jaux = 0
 501           iaux = 4
 502 c
 503 #ifdef _DEBUG_HOMARD_
 504         write (ulsort,texte(langue,3)) 'UTB05B', nompro
 505 #endif
 506           call utb05b ( jaux, iaux, nbeexa, tabaur, tbdaux,
 507      >                  nbiter, rafdef, nbvoto,
 508      >                  tbiau2,
 509      >                  ulbila,
 510      >                  ulsort, langue, codret )
 511 c
 512         endif
 513 c
 514       endif
 515 c
 516       endif
 517 c
 518       endif
 519 c
 520       endif
 521 c
 522 c====
 523 c 8. la fin
 524 c====
 525 c
 526       if ( codret.ne.0 ) then
 527 c
 528 #include "envex2.h"
 529 c
 530       write (ulsort,texte(langue,1)) 'Sortie', nompro
 531       write (ulsort,texte(langue,2)) codret
 532 c
 533       endif
 534 c
 535 #ifdef _DEBUG_HOMARD_
 536       write (ulsort,texte(langue,1)) 'Sortie', nompro
 537       call dmflsh (iaux)
 538 #endif
 539 c
 540       end