src/tool/Utilitaire/utb11f.F

   1       subroutine utb11f ( nubloc, nbbl00, typen0, typent,
   2      >                    nublen, tabau2, tabau3, tabau4,
   3      >                    ulbila,
   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 - Bilan sur le maillage - option 11 - phase f
  26 c    --           -                              --         -
  27 c    Impressions
  28 c ______________________________________________________________________
  29 c .        .     .        .                                            .
  30 c .  nom   . e/s . taille .           description                      .
  31 c .____________________________________________________________________.
  32 c . nubloc . e   .   1    . numero du bloc s'il y en a plusieurs       .
  33 c .        .     .        . -1 si un seul bloc                         .
  34 c . nbbl00 . e   .   1    . si bloc volumique, nombre de blocs         .
  35 c .        .     .        . surfaciques associes                       .
  36 c .        .     .        . si bloc surfacique, nombre de blocs        .
  37 c .        .     .        . lineiques associes                         .
  38 c . typen0 . e   .   1    . type d'entites des blocs de meme type      .
  39 c . typent . e   .   1    . type d'entites du bloc                     .
  40 c .        .     .        .   1 : aretes                               .
  41 c .        .     .        .   2 : triangles                            .
  42 c .        .     .        .   3 : tetraedres                           .
  43 c .        .     .        .   4 : quadrangles                          .
  44 c .        .     .        .   5 : pyramides                            .
  45 c .        .     .        .   6 : hexaedres                            .
  46 c .        .     .        .   7 : pentaedres                           .
  47 c .        .     .        .   8 : triangle et quadrangle               .
  48 c .        .     .        .   9 : melange de volumes                   .
  49 c . nublen . e   .-nbquto . numero du bloc pour chaque entite          .
  50 c .        .     .   :*   .                                            .
  51 c . tabau2 . e   . nbnoto . nombre de cas ou un noeud est dans le bloc .
  52 c . tabau3 . e   . nbarto . nombre de cas ou une arete est dans le bloc.
  53 c . tabau4 . e   .-nbquto . nombre de fois ou la face est dans le bloc .
  54 c .        .     . :nbtrto. volumique :                                .
  55 c .        .     .        . 0 : jamais                                 .
  56 c .        .     .        . 1 : c'est une face du bord                 .
  57 c .        .     .        . 2 : c'est une face interieure              .
  58 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  59 c .        .     .        . si 0 : on n'ecrit rien                     .
  60 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  61 c . langue . e   .    1   . langue des messages                        .
  62 c .        .     .        . 1 : francais, 2 : anglais                  .
  63 c . codret .  s  .    1   . code de retour des modules                 .
  64 c .        .     .        . 0 : pas de probleme                        .
  65 c .        .     .        . 1 : probleme                               .
  66 c .____________________________________________________________________.
  67 c
  68 c====
  69 c 0. declarations et dimensionnement
  70 c====
  71 c
  72 c 0.1. ==> generalites
  73 c
  74       implicit none
  75       save
  76 c
  77       character*6 nompro
  78       parameter ( nompro = 'UTB11F' )
  79 c
  80 #include "nblang.h"
  81 c
  82 c 0.2. ==> communs
  83 c
  84 #include "envca1.h"
  85 #include "nombno.h"
  86 #include "nombar.h"
  87 #include "nombtr.h"
  88 #include "nombqu.h"
  89 #include "nombte.h"
  90 #include "nombpy.h"
  91 #include "nombhe.h"
  92 #include "nombpe.h"
  93 c
  94 #include "impr02.h"
  95 c
  96 c 0.3. ==> arguments
  97 c
  98       integer nubloc, nbbl00, typen0, typent
  99       integer nublen(-nbquto:*)
 100       integer tabau2(nbnoto)
 101       integer tabau3(nbarto)
 102       integer tabau4(-nbquto:*)
 103 c
 104       integer ulbila
 105       integer ulsort, langue, codret
 106 c
 107 c 0.4. ==> variables locales
 108 c
 109       integer iaux, jaux, kaux
 110       integer nbnobl, nbarbl, nbfabl, nbvobl
 111       integer nbnomu
 112       integer nbenbl
 113       integer euler
 114       integer dimblo
 115 c
 116       integer nbmess
 117       parameter (nbmess = 20 )
 118       character*80 texte(nblang,nbmess)
 119 c
 120 c 0.5. ==> initialisations
 121 c ______________________________________________________________________
 122 c
 123 c====
 124 c 1. messages
 125 c====
 126 c
 127 #include "impr01.h"
 128 c
 129 #ifdef _DEBUG_HOMARD_
 130       write (ulsort,texte(langue,1)) 'Entree', nompro
 131       call dmflsh (iaux)
 132 #endif
 133 c
 134       texte(1,4) = '(/,a,'' : bloc numero'',i5)'
 135       texte(1,6) =
 136      >'(5x,''*'',19x,''Blocs de '',a,14x,''*'')'
 137       texte(1,7) =
 138      >'(5x,''* Les '',a,'' sont en un seul bloc.'',15x,''*'')'
 139       texte(1,8) =
 140      >'(5x,''* Bloc numero '',i8,5x,  '' *'',11x,''1 '',a,'' *'')'
 141       texte(1,9) =
 142      >'(5x,''* Bloc numero '',i8,5x,  '' * '',i11,1x,a,'' *'')'
 143       texte(1,10) =
 144      >'(5x,''*    Nombre de cavites internes :'',i5,19x,''*'')'
 145       texte(1,11) =
 146      >'(5x,''*    Nombre de trous traversant :'',i5,19x,''*'')'
 147       texte(1,12) =
 148      >'(5x,''*    Cette surface est fermee.'',27x,''*'')'
 149       texte(1,13) =
 150      >'(5x,''*    Cette surface a 1 bord.'',29x,''*'')'
 151       texte(1,14) =
 152      >'(5x,''*    Cette surface a'',i5,'' bords.'',25x,''*'')'
 153       texte(1,15) =
 154      >'(5x,''*    Cette ligne est fermee.'',29x,''*'')'
 155       texte(1,16) =
 156      >'(5x,''*    Cette ligne a deux extremites.'',22x,''*'')'
 157       texte(1,17) =
 158      >'(5x,''*    Cette ligne a'',i3,'' extremites.'',24x,''*'')'
 159       texte(1,18) =
 160      >'(5x,''*    Cette ligne a'',i5,'' noeuds multiples.'',16x,''*'')'
 161       texte(1,20) = '(''. Nombre de '',a,'':'',i11)'
 162 c
 163       texte(2,4) = '(/,a,'' : block #'',i5)'
 164       texte(2,6) =
 165      >'(5x,''*'',19x,''Blocks of '',a,13x,''*'')'
 166       texte(2,7) =
 167      >'(5x,''* All the '',a,'' are connected.'',18x,''*'')'
 168       texte(2,8) =
 169      >'(5x,''* Block # '',i8,9x,      '' *'',11x,''1'',1x,a,'' *'')'
 170       texte(2,9) =
 171      >'(5x,''* Block # '',i8,9x,      '' * '',i11,1x,a,'' *'')'
 172       texte(2,10) =
 173      >'(5x,''*    Number of internal cavities :'',i5,18x,''*'')'
 174       texte(2,11) =
 175      >'(5x,''*    Number of crossing holes    :'',i5,18x,''*'')'
 176       texte(2,12) =
 177      >'(5x,''*    This surface does not have any boundary.'',12x,''*'')'
 178       texte(2,13) =
 179      >'(5x,''*    This surface has 1 boundary.'',24x,''*'')'
 180       texte(2,14) =
 181      >'(5x,''*    This surface has'',i5,'' boundaries.'',19x,''*'')'
 182       texte(2,15) =
 183      >'(5x,''*    This line is closed.'',32x,''*'')'
 184       texte(2,16) =
 185      >'(5x,''*    This line has 2 ends.'',31x,''*'')'
 186       texte(2,17) =
 187      >'(5x,''*    This line has'',i3,'' ends.'',32x,''*'')'
 188       texte(2,18) =
 189      >'(5x,''*    This line has'',i5,'' multiples nodes.'',17x,''*'')'
 190       texte(2,20) = '(''. Number of '',a,'':'',i11)'
 191 c
 192 #ifdef _DEBUG_HOMARD_
 193       write (ulsort,texte(langue,4)) mess14(langue,4,typent),abs(nubloc)
 194 #endif
 195 c
 196 #include "impr03.h"
 197 c
 198 10100 format(/,5x,58('*'))
 199 10200 format(  5x,58('*'))
 200 c
 201       codret = 0
 202 c
 203       if ( typent.eq.1 ) then
 204         dimblo = 1
 205       elseif ( typent.eq.2 .or. typent.eq.4 .or. typent.eq.8 ) then
 206         dimblo = 2
 207       else
 208         dimblo = 3
 209       endif
 210 #ifdef _DEBUG_HOMARD_
 211       write (ulsort,*) 'dimblo =', dimblo
 212 #endif
 213 c
 214 c====
 215 c 2. Decompte des nombres d'entites
 216 c====
 217 c 2.1. ==> Volumes
 218 c
 219       if ( dimblo.eq.3 ) then
 220 c
 221         iaux = abs(nubloc)
 222         kaux = nbteto + nbpyto + nbheto + nbpeto - nbquto - 1
 223         nbvobl = 0
 224         do 21 , jaux = -nbquto , kaux
 225 cgn        write(ulsort, *)jaux,nublen(jaux)
 226           if ( nublen(jaux).eq.iaux ) then
 227             nbvobl = nbvobl + 1
 228           endif
 229    21   continue
 230         nbenbl = nbvobl
 231 c
 232       endif
 233 c
 234 c 2.2. ==> Faces
 235 c
 236       if ( dimblo.eq.3 ) then
 237 c
 238         nbfabl = 0
 239         do 221 , iaux = -nbquto , nbtrto
 240           if ( tabau4(iaux).gt.0 ) then
 241             nbfabl = nbfabl + 1
 242           endif
 243   221   continue
 244 c
 245       elseif ( dimblo.eq.2 ) then
 246 c
 247         iaux = abs(nubloc)
 248         nbfabl = 0
 249         do 222 , jaux = -nbquto , nbtrto
 250           if ( nublen(jaux).eq.iaux ) then
 251             nbfabl = nbfabl + 1
 252           endif
 253   222   continue
 254         nbenbl = nbfabl
 255 c
 256       endif
 257 c
 258 c 2.3. ==> Aretes
 259 c
 260       nbarbl = 0
 261 c
 262       if ( dimblo.eq.1 ) then
 263 c
 264         iaux = abs(nubloc)
 265         kaux = nbarto - nbquto - 1
 266         do 231 , jaux = -nbquto , kaux
 267 cgn          write(ulsort, *)iaux,nublen(iaux)
 268           if ( nublen(jaux).eq.iaux ) then
 269             nbarbl = nbarbl + 1
 270           endif
 271   231   continue
 272         nbenbl = nbarbl
 273 cgn       write(ulsort, *)nbarbl
 274 c
 275       else
 276 c
 277         do 232 , iaux = 1 , nbarto
 278 cgn          write(ulsort, *)iaux,tabau3(iaux)
 279           if ( tabau3(iaux).gt.0 ) then
 280             nbarbl = nbarbl + 1
 281           endif
 282   232   continue
 283 c
 284       endif
 285 c
 286 c 2.4. ==> Noeuds
 287 c
 288       nbnobl = 0
 289       nbnomu = 0
 290 c
 291       if ( dimblo.eq.1 ) then
 292 c
 293         do 241 , iaux = 1 , nbnoto
 294 cgn          write(ulsort, *)iaux,tabau2(iaux)
 295           if ( tabau2(iaux).eq.1 ) then
 296             nbnobl = nbnobl + 1
 297           elseif ( tabau2(iaux).ge.3 ) then
 298             nbnomu = nbnomu + 1
 299           endif
 300   241   continue
 301 c
 302       else
 303 c
 304         do 242 , iaux = 1 , nbnoto
 305 cgn          write(ulsort, *)iaux,tabau2(iaux)
 306           if ( tabau2(iaux).gt.0 ) then
 307             nbnobl = nbnobl + 1
 308           endif
 309   242   continue
 310 c
 311       endif
 312 c
 313 #ifdef _DEBUG_HOMARD_
 314       write (ulsort,texte(langue,20)) mess14(langue,3,-1), nbnobl
 315       write (ulsort,texte(langue,20)) mess14(langue,3,1), nbarbl
 316       if ( dimblo.eq.3 ) then
 317         write (ulsort,texte(langue,20)) mess14(langue,3,8), nbfabl
 318         write (ulsort,texte(langue,20))
 319      >        'blocs de '//mess14(langue,3,8), nbbl00
 320         write (ulsort,texte(langue,20)) mess14(langue,3,typent), nbvobl
 321       elseif ( dimblo.eq.2 ) then
 322         write (ulsort,texte(langue,20))
 323      >        'blocs de '//mess14(langue,3,1), nbbl00
 324         write (ulsort,texte(langue,20)) mess14(langue,3,typent), nbfabl
 325       endif
 326 #endif
 327 c
 328 c====
 329 c 3. Impression
 330 c====
 331 #ifdef _DEBUG_HOMARD_
 332       write(ulsort,*) '3. impression ; codret = ', codret
 333 #endif
 334 c 3.1. ==> En tete au premier passage
 335 c
 336       if ( nubloc.eq.1 ) then
 337         write (ulbila,10100)
 338         write (ulbila,texte(langue,6)) mess14(langue,3,typen0)
 339         write (ulbila,10200)
 340       endif
 341 c
 342 c 3.2. ==> Texte
 343 c
 344       if ( nubloc.lt.0 ) then
 345 c
 346         write (ulbila,10100)
 347         write (ulbila,texte(langue,7)) mess14(langue,3,typent)
 348 c
 349       else
 350 c
 351         if ( nbenbl.eq.1 ) then
 352           write (ulbila,texte(langue,8)) nubloc, mess14(langue,1,typent)
 353         else
 354           write (ulbila,texte(langue,9)) nubloc, nbenbl,
 355      >                                   mess14(langue,3,typent)
 356         endif
 357 c
 358       endif
 359 c
 360 c 3.3. ==> Trous ?
 361 c          Remarques :
 362 c          . on ne sait le faire que pour un maillage conforme
 363 c          . en mode optimise, on n'imprime que s'il y a un trou.
 364 c
 365 c 3.3.1. ==> Examen d'un volume
 366 c
 367       if ( dimblo.eq.3 ) then
 368 c
 369         if ( ( maconf.eq.-1 ) .or. ( maconf.eq.0 ) ) then
 370 c
 371           euler = nbbl00 + nbvobl - nbfabl + nbarbl - nbnobl
 372 #ifdef _DEBUG_HOMARD_
 373           write (ulsort,90002) '  nbbl00', nbbl00
 374           write (ulsort,90002) '+ nbvobl', nbvobl
 375           write (ulsort,90002) '- nbfabl', -nbfabl
 376           write (ulsort,90002) '+ nbarbl', nbarbl
 377           write (ulsort,90002) '- nbnobl', - nbnobl
 378           write (ulsort,90002) '= euler', euler
 379 #endif
 380 c
 381 #ifdef _DEBUG_HOMARD_
 382 #else
 383           if ( euler.gt.0 .or. nbbl00.gt.1 ) then
 384 #endif
 385 c
 386             if ( nbbl00.gt.1 ) then
 387               write (ulbila,texte(langue,10)) nbbl00 - 1
 388             endif
 389             if ( euler.gt.0 ) then
 390               write (ulbila,texte(langue,11)) euler
 391             endif
 392 c
 393 #ifdef _DEBUG_HOMARD_
 394 #else
 395           endif
 396 #endif
 397 c
 398         endif
 399 c
 400 c 3.3.2. ==> Examen d'une surface
 401 c
 402       elseif ( dimblo.eq.2 ) then
 403 c
 404 #ifdef _DEBUG_HOMARD_
 405 #else
 406         if ( nbbl00.ne.1 ) then
 407 #endif
 408           if ( nbbl00.eq.0 ) then
 409             write (ulbila,texte(langue,12))
 410           elseif ( nbbl00.eq.1 ) then
 411             write (ulbila,texte(langue,13))
 412           else
 413             write (ulbila,texte(langue,14)) nbbl00
 414           endif
 415 c
 416 #ifdef _DEBUG_HOMARD_
 417 #else
 418         endif
 419 #endif
 420 c
 421 c 3.3.3. ==> Examen d'une ligne
 422 c
 423       else
 424 c
 425 #ifdef _DEBUG_HOMARD_
 426 #else
 427         if ( nbnobl.ne.2 ) then
 428 #endif
 429           if ( nbnobl.eq.0 ) then
 430             write (ulbila,texte(langue,15))
 431           elseif ( nbnobl.eq.2 ) then
 432             write (ulbila,texte(langue,16))
 433           else
 434             write (ulbila,texte(langue,17)) nbnobl
 435           endif
 436           if ( nbnomu.gt.0 ) then
 437             write (ulbila,texte(langue,18)) nbnomu
 438           endif
 439 c
 440 #ifdef _DEBUG_HOMARD_
 441 #else
 442         endif
 443 #endif
 444 c
 445       endif
 446 c
 447 #ifdef _DEBUG_HOMARD_
 448       write (ulsort,texte(langue,1)) 'Sortie', nompro
 449       call dmflsh (iaux)
 450 #endif
 451 c
 452       end