src/tool/Utilitaire/utb05a.F

   1       subroutine utb05a ( 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      >                    nbeexa, tbiau1, tbiau2, tabaur, tabau2,
  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 05 - etape a
  36 c    --           -              --         -
  37 c  remarque : utb05a et utb19a sont des clones
  38 c ______________________________________________________________________
  39 c
  40 c but : controle de la qualite 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 de la qualite des triangles     .
  48 c .        .     .        . 3 : sortie de la qualite des tetraedres    .
  49 c .        .     .        . 4 : sortie de la qualite des quadrangles   .
  50 c .        .     .        . 5 : sortie de la qualite des pyramides     .
  51 c .        .     .        . 6 : sortie de la qualite des hexaedres     .
  52 c .        .     .        . 7 : sortie de la qualite 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 . nbeexa .  s  .   1    . nombre d'entites examinees                 .
  93 c . tbiau1 .  a  .    *   . liste des entites examinees                .
  94 c . tbiau2 .  a  .    *   . tableau entier auxiliaire                  .
  95 c . tabaur .  a  .    *   . qualite des entites                        .
  96 c . tabau2 .  a  .    *   . qualite des entites                        .
  97 c . nbiter . e   .   1    . numero de l'iteration courante             .
  98 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  99 c . ulsort . e   .   1    . unite logique de la sortie generale        .
 100 c . langue . e   .    1   . langue des messages                        .
 101 c .        .     .        . 1 : francais, 2 : anglais                  .
 102 c . codret .  s  .    1   . code de retour des modules                 .
 103 c .        .     .        . 0 : pas de probleme                        .
 104 c .        .     .        . 1 : probleme                               .
 105 c .____________________________________________________________________.
 106 c
 107 c====
 108 c 0. declarations et dimensionnement
 109 c====
 110 c
 111 c 0.1. ==> generalites
 112 c
 113       implicit none
 114       save
 115 c
 116       character*6 nompro
 117       parameter ( nompro = 'UTB05A' )
 118 c
 119 #include "nblang.h"
 120 #include "coftex.h"
 121 c
 122 c 0.2. ==> communs
 123 c
 124 #include "envex1.h"
 125 c
 126 #include "dicfen.h"
 127 #include "nbfami.h"
 128 #include "nombno.h"
 129 #include "nombar.h"
 130 #include "nombtr.h"
 131 #include "nombqu.h"
 132 #include "nombte.h"
 133 #include "nombhe.h"
 134 #include "nombpy.h"
 135 #include "nombpe.h"
 136 #include "envca1.h"
 137 #include "impr02.h"
 138 c
 139 c 0.3. ==> arguments
 140 c
 141       double precision coonoe(nbnoto,sdim)
 142       double precision tabaur(*)
 143       double precision tabau2(*)
 144 c
 145       integer choix
 146 c
 147       integer somare(2,nbarto)
 148       integer hettri(nbtrto), aretri(nbtrto,3)
 149       integer cfatri(nctftr,nbftri), famtri(nbtrto)
 150       integer hetqua(nbquto), arequa(nbquto,4)
 151       integer cfaqua(nctfqu,nbfqua), famqua(nbquto)
 152       integer tritet(nbtecf,4), cotrte(nbtecf,4), aretet(nbteca,6)
 153       integer hettet(nbteto)
 154       integer quahex(nbhecf,6), coquhe(nbhecf,6), arehex(nbheca,12)
 155       integer hethex(nbheto)
 156       integer facpyr(nbpycf,5), cofapy(nbpycf,5), arepyr(nbpyca,8)
 157       integer hetpyr(nbpyto)
 158       integer facpen(nbpecf,5), cofape(nbpecf,5), arepen(nbpeca,9)
 159       integer hetpen(nbpeto)
 160       integer nbeexa
 161       integer tbiau1(*), tbiau2(*)
 162       integer nbiter
 163 c
 164       integer ulbila
 165       integer ulsort, langue, codret
 166 c
 167 c 0.4. ==> variables locales
 168 c
 169       integer letria, lequad
 170       integer iaux, jaux
 171       integer nbvoto
 172 c
 173       double precision daux1, daux2
 174       double precision tbdaux(1)
 175 c
 176       integer nbmess
 177       parameter (nbmess = 10 )
 178       character*80 texte(nblang,nbmess)
 179 c
 180 c 0.5. ==> initialisations
 181 c ______________________________________________________________________
 182 c
 183 c====
 184 c 1. titre
 185 c====
 186 c
 187 #include "impr01.h"
 188 c
 189 #ifdef _DEBUG_HOMARD_
 190       write (ulsort,texte(langue,1)) 'Entree', nompro
 191       call dmflsh (iaux)
 192 #endif
 193 c
 194       texte(1,4) =
 195      > '(//,3x,''QUALITES DES MAILLES'',/,3x,20(''=''))'
 196       texte(1,5) = '(3x,''Qualite '',a,'' des '',a,'' : '',g12.5)'
 197       texte(1,6) = '(3x,''Nombre de '',a,'' a examiner : '',i8)'
 198       texte(1,7) = '(3x,''Nombre de '',a,'' aplatis : '',i8)'
 199 c
 200       texte(2,4) =
 201      > '(//,3x,''QUALITIES OF MESHES'',/,3x,19(''=''))'
 202       texte(2,5) = '(3x,''Quality '',a,'' of '',a,'': '',g12.5)'
 203       texte(2,6) = '(3x,''Number of '',a,'' to be examined: '',i8)'
 204       texte(2,7) = '(3x,''Number of flat '',a,'': '',i8)'
 205 c
 206 #include "impr03.h"
 207 c
 208       write (ulsort,texte(langue,4))
 209       if ( ulbila.ne.ulsort ) then
 210         write (ulbila,texte(langue,4))
 211       endif
 212 c
 213       codret = 0
 214 c
 215       nbvoto = nbteto + nbpyto + nbheto + nbpeto
 216 c
 217 c====
 218 c 2. calcul des qualites des tetraedres
 219 c===
 220 c
 221       if ( choix.eq.0 .or. choix.eq.3 ) then
 222 c
 223         if ( nbteto.ne.0 ) then
 224 c
 225           iaux = 3
 226 c
 227 #ifdef _DEBUG_HOMARD_
 228       write (ulsort,texte(langue,3)) 'UTB05C_te', nompro
 229 #endif
 230           call utb05c ( choix,
 231      >                  iaux, nbteto, nbtecf, nbteca,
 232      >                  coonoe, somare,
 233      >                  aretri, arequa,
 234      >                  hettet, tritet, cotrte, aretet,
 235      >                  nbiter,
 236      >                  nbeexa, tbiau1, tbiau2, tabaur, tabau2,
 237      >                  ulbila,
 238      >                  ulsort, langue, codret )
 239 c
 240         endif
 241 c
 242       endif
 243 c
 244 c====
 245 c 3. calcul des qualites des pyramides
 246 c===
 247 #ifdef _DEBUG_HOMARD_
 248       write (ulsort,90002) '3. pyramides ; codret', codret
 249 #endif
 250 c
 251       if ( codret.eq.0 ) then
 252 c
 253       if ( choix.eq.0 .or. choix.eq.5 ) then
 254 c
 255         if ( nbpyto.ne.0 ) then
 256 c
 257           iaux = 5
 258 c
 259 #ifdef _DEBUG_HOMARD_
 260       write (ulsort,texte(langue,3)) 'UTB05C_py', nompro
 261 #endif
 262           call utb05c ( choix,
 263      >                  iaux, nbpyto, nbpycf, nbpyca,
 264      >                  coonoe, somare,
 265      >                  aretri, arequa,
 266      >                  hetpyr, facpyr, cofapy, arepyr,
 267      >                  nbiter,
 268      >                  nbeexa, tbiau1, tbiau2, tabaur, tabau2,
 269      >                  ulbila,
 270      >                  ulsort, langue, codret )
 271 c
 272         endif
 273 c
 274       endif
 275 c
 276       endif
 277 c
 278 c====
 279 c 4. calcul des qualites des hexaedres
 280 c===
 281 #ifdef _DEBUG_HOMARD_
 282       write (ulsort,90002) '4. hexaedres ; codret', codret
 283 #endif
 284 c
 285       if ( codret.eq.0 ) then
 286 c
 287       if ( choix.eq.0 .or. choix.eq.6 ) then
 288 c
 289         if ( nbheto.ne.0 ) then
 290 c
 291           iaux = 6
 292 c
 293 #ifdef _DEBUG_HOMARD_
 294       write (ulsort,texte(langue,3)) 'UTB05C_he', nompro
 295 #endif
 296           call utb05c ( choix,
 297      >                  iaux, nbheto, nbhecf, nbheca,
 298      >                  coonoe, somare,
 299      >                  aretri, arequa,
 300      >                  hethex, quahex, coquhe, arehex,
 301      >                  nbiter,
 302      >                  nbeexa, tbiau1, tbiau2, tabaur, tabau2,
 303      >                  ulbila,
 304      >                  ulsort, langue, codret )
 305 c
 306         endif
 307 c
 308       endif
 309 c
 310       endif
 311 c
 312 c====
 313 c 5. calcul des qualites des pentaedres
 314 c===
 315 #ifdef _DEBUG_HOMARD_
 316       write (ulsort,90002) '5. pentaedres ; codret', codret
 317 #endif
 318 c
 319       if ( codret.eq.0 ) then
 320 c
 321       if ( choix.eq.0 .or. choix.eq.7 ) then
 322 c
 323         if ( nbpeto.ne.0 ) then
 324 c
 325           iaux = 7
 326 c
 327 #ifdef _DEBUG_HOMARD_
 328       write (ulsort,texte(langue,3)) 'UTB05C_pe', nompro
 329 #endif
 330           call utb05c ( choix,
 331      >                  iaux, nbpeto, nbpecf, nbpeca,
 332      >                  coonoe, somare,
 333      >                  aretri, arequa,
 334      >                  hetpen, facpen, cofape, arepen,
 335      >                  nbiter,
 336      >                  nbeexa, tbiau1, tbiau2, tabaur, tabau2,
 337      >                  ulbila,
 338      >                  ulsort, langue, codret )
 339 c
 340         endif
 341 c
 342       endif
 343 c
 344       endif
 345 c
 346 c====
 347 c 6. calcul des qualites des triangles d'un maillage 2d ou 2,5d
 348 c====
 349 #ifdef _DEBUG_HOMARD_
 350       write (ulsort,90002) '6. triangles ; codret', codret
 351 #endif
 352 c
 353       if ( codret.eq.0 ) then
 354 c
 355       if ( choix.eq.0 .or. choix.eq.2 ) then
 356 c
 357       if ( nbtrto.ne.0 ) then
 358 c
 359 c 6.1. ==> liste des triangles a examiner :
 360 c       . en l'absence de tetraedre, pentaedre et pyramide, ce sont
 361 c         tous les triangles actifs ;
 362 c       . en presence de tetraedre, pentaedre ou pyramide, ce sont les
 363 c         triangles actifs qui sont des elements de calcul
 364 c
 365       nbeexa = 0
 366 c
 367       if ( nbteto.eq.0 .and. nbpeto.eq.0 .and. nbpyto.eq.0 ) then
 368 c
 369         do 611 , letria = 1 , nbtrto
 370           if ( mod(hettri(letria),10).eq.0 ) then
 371             nbeexa = nbeexa + 1
 372             tbiau1(nbeexa) = letria
 373           endif
 374   611   continue
 375 c
 376       else
 377 c
 378         do 612 , letria = 1 , nbtrto
 379           if ( mod(hettri(letria),10).eq.0 .and.
 380      >         cfatri(cotyel,famtri(letria)).ne.0 ) then
 381             nbeexa = nbeexa + 1
 382             tbiau1(nbeexa) = letria
 383           endif
 384   612   continue
 385 c
 386       endif
 387 c
 388 #ifdef _DEBUG_HOMARD_
 389       write (ulsort,texte(langue,6)) mess14(langue,3,2), nbeexa
 390 #endif
 391 c
 392 c 6.2. ==> calcul
 393 #ifdef _DEBUG_HOMARD_
 394       write (ulsort,90002) '6.2. calcul ; codret', codret
 395 #endif
 396 c
 397       if ( nbeexa.gt.0 ) then
 398 c
 399       do 62 , iaux = 1 , nbeexa
 400 c
 401         letria = tbiau1(iaux)
 402 c
 403         call utqtri ( letria, daux1, daux2,
 404      >                coonoe, somare, aretri )
 405 c
 406         tabaur(iaux) = daux1
 407 c
 408    62 continue
 409 c
 410       endif
 411 c
 412 c 6.3. ==> impression sur la sortie standard et sur un fichier
 413 c          a exploiter par xmgrace
 414 c
 415       if ( choix.eq.0 ) then
 416 c
 417         if ( nbeexa.gt.0 ) then
 418 c
 419           jaux = 1
 420           iaux = 2
 421 c
 422 #ifdef _DEBUG_HOMARD_
 423           write (ulsort,texte(langue,3)) 'UTB05B tri', nompro
 424 #endif
 425           call utb05b ( jaux, iaux, nbeexa, tabaur, tbdaux,
 426      >                  nbiter, rafdef, nbvoto,
 427      >                  tbiau2,
 428      >                  ulbila,
 429      >                  ulsort, langue, codret )
 430 c
 431           endif
 432 c
 433         endif
 434 c
 435       endif
 436 c
 437       endif
 438 c
 439       endif
 440 c
 441 c====
 442 c 7. calcul des qualites des quadrangles d'un maillage 2d ou 2,5d
 443 c====
 444 #ifdef _DEBUG_HOMARD_
 445       write (ulsort,90002) '7. quadrangles ; codret', codret
 446 #endif
 447 c
 448       if ( codret.eq.0 ) then
 449 c
 450       if ( choix.eq.0 .or. choix.eq.4 ) then
 451 c
 452       if ( nbquto.ne.0 ) then
 453 c
 454 c 7.1. ==> liste des quadrangles a examiner :
 455 c       . en l'absence d'hexaedre, pentaedre et pyramide, ce sont
 456 c         tous les quadrangles actifs ;
 457 c       . en presence d'hexaedre, pentaedre ou pyramide, ce sont les
 458 c         quadrangles actifs qui sont des elements de calcul
 459 c
 460       nbeexa = 0
 461 c
 462       if ( nbheto.eq.0 .and. nbpeto.eq.0 .and. nbpyto.eq.0 ) then
 463 c
 464         do 711 , lequad = 1 , nbquto
 465           if ( mod(hetqua(lequad),100).eq.0 ) then
 466             nbeexa = nbeexa + 1
 467             tbiau1(nbeexa) = lequad
 468           endif
 469   711   continue
 470 c
 471       else
 472 c
 473         do 712 , lequad = 1 , nbquto
 474           if ( mod(hetqua(lequad),100).eq.0 .and.
 475      >         cfaqua(cotyel,famqua(lequad)).ne.0 ) then
 476             nbeexa = nbeexa + 1
 477             tbiau1(nbeexa) = lequad
 478           endif
 479   712   continue
 480 c
 481       endif
 482 c
 483 #ifdef _DEBUG_HOMARD_
 484       write (ulsort,texte(langue,6)) mess14(langue,3,4), nbeexa
 485 #endif
 486 c
 487 c 7.2. ==> calcul
 488 #ifdef _DEBUG_HOMARD_
 489       write (ulsort,90002) '7.2. calcul ; codret', codret
 490 #endif
 491 c
 492       if ( nbeexa.gt.0 ) then
 493 c
 494       do 72 , iaux = 1 , nbeexa
 495 c
 496         lequad = tbiau1(iaux)
 497 c
 498         call utqqua ( lequad, daux1, daux2,
 499      >                coonoe, somare, arequa )
 500 c
 501         tabaur(iaux) = daux1
 502 c
 503    72 continue
 504 c
 505       endif
 506 c
 507 c 7.3. ==> impression sur la sortie standard et sur un fichier
 508 c          a exploiter par xmgrace
 509 c
 510       if ( choix.eq.0 ) then
 511 c
 512         if ( nbeexa.gt.0 ) then
 513 c
 514           jaux = 1
 515           iaux = 4
 516 c
 517 #ifdef _DEBUG_HOMARD_
 518           write (ulsort,texte(langue,3)) 'UTB05B qua', nompro
 519 #endif
 520           call utb05b ( jaux, iaux, nbeexa, tabaur, tbdaux,
 521      >                  nbiter, rafdef, nbvoto,
 522      >                  tbiau2,
 523      >                  ulbila,
 524      >                  ulsort, langue, codret )
 525 c
 526         endif
 527 c
 528       endif
 529 c
 530       endif
 531 c
 532       endif
 533 c
 534       endif
 535 c
 536 c====
 537 c 8. la fin
 538 c====
 539 c
 540       if ( codret.ne.0 ) then
 541 c
 542 #include "envex2.h"
 543 c
 544       write (ulsort,texte(langue,1)) 'Sortie', nompro
 545       write (ulsort,texte(langue,2)) codret
 546 c
 547       endif
 548 c
 549 #ifdef _DEBUG_HOMARD_
 550       write (ulsort,texte(langue,1)) 'Sortie', nompro
 551       call dmflsh (iaux)
 552 #endif
 553 c
 554       end