src/tool/Utilitaire/utb13e.F

   1       subroutine utb13e ( dimsd, option,
   2      >                    nbfmed, numfam,
   3      >                    grfmpo, grfmtl, grfmtb,
   4      >                    nbgrfm, nomgro, lgnogr,
   5      >                    famnbv, famnum, famval,
   6      >                    lifagr,
   7      >                    ulbila,
   8      >                    ulsort, langue, codret )
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c    UTilitaire - Bilan sur le maillage - option 13 - phase e
  30 c    --           -                              --         -
  31 c ______________________________________________________________________
  32 c
  33 c impression
  34 c ______________________________________________________________________
  35 c .        .     .        .                                            .
  36 c .  nom   . e/s . taille .           description                      .
  37 c .____________________________________________________________________.
  38 c . dimsd  . e   .    1   . dimension du sous-domaine                  .
  39 c . option . e   .    1   . 1 : affichage pour les sous-domaines       .
  40 c .        .     .        . 2 : affichage pour les joints simples      .
  41 c .        .     .        . 3 : affichage pour les joints triples      .
  42 c .        .     .        . 4 : affichage pour les joints quadruples   .
  43 c . nbfmed . e   .    1   . nombre de familles au sens MED             .
  44 c . numfam . e   . nbfmed . numero des familles au sens MED            .
  45 c . grfmpo . e   .0:nbfmed. pointeur des groupes des familles          .
  46 c . grfmtl . e   .   *    . taille des groupes des familles            .
  47 c . grfmtb . e   .10ngrouc. table des groupes des familles             .
  48 c . nbgrfm . e   .    1   . nombre de groupes                          .
  49 c . nomgro . e   .char*(*). noms des groupes (paquets de 10char8)      .
  50 c . lgnogr . e   . nbgrfm . longueur des noms des groupes              .
  51 c . famnbv . e   .   1    . famille : nombre des valeurs               .
  52 c . famnum .  a  .   *    . famille : numero avec une valeur           .
  53 c . famval .  a  .   *    . famille : la valeur                        .
  54 c . lifagr .  a  .   *    . liste des familles contenant le groupe     .
  55 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  56 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  57 c . langue . e   .    1   . langue des messages                        .
  58 c .        .     .        . 1 : francais, 2 : anglais                  .
  59 c . codret .  s  .    1   . code de retour des modules                 .
  60 c .        .     .        . 0 : pas de probleme                        .
  61 c .        .     .        . 1 : probleme                               .
  62 c .____________________________________________________________________.
  63 c
  64 c====
  65 c 0. declarations et dimensionnement
  66 c====
  67 c
  68 c 0.1. ==> generalites
  69 c
  70       implicit none
  71       save
  72 c
  73       character*6 nompro
  74       parameter ( nompro = 'UTB13E' )
  75 c
  76 #include "nblang.h"
  77 #include "consts.h"
  78 c
  79 c 0.2. ==> communs
  80 c
  81 c 0.3. ==> arguments
  82 c
  83       integer dimsd, option
  84       integer nbfmed, numfam(nbfmed)
  85       integer grfmpo(0:nbfmed)
  86       integer grfmtl(*)
  87       integer nbgrfm, lgnogr(nbgrfm)
  88       integer famnbv
  89 c
  90       character*8 grfmtb(*)
  91       character*8 nomgro(*)
  92 c
  93       integer famnum(famnbv)
  94       double precision famval(famnbv)
  95 c
  96       integer  lifagr(*)
  97 c
  98       integer ulbila
  99       integer ulsort, langue, codret
 100 c
 101 c 0.4. ==> variables locales
 102 c
 103       integer iaux, jaux, kaux
 104       integer lnogro, nbfgro
 105       integer nblign
 106       integer imprgr
 107 c
 108       logical logaux
 109 c
 110       double precision daux
 111       double precision vmin, vmax
 112 c
 113       character*80 saux80
 114 c
 115       integer nbmess
 116       parameter (nbmess = 20 )
 117       character*80 texte(nblang,nbmess)
 118       character*8 mess08(nblang,0:3)
 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,5) ='(''Nombre de familles :'',i8)'
 135       texte(1,6) ='(5x,''*'',21x,''Sous-domaines '',i1,''D'',20x,''*'')'
 136       texte(1,7) = '(5x,''*'',18x,''Numero'',17x,''*   '',a8,''   *'')'
 137       texte(1,11) ='(5x,''*'',22x,''Joints simples'',22x,''*'')'
 138       texte(1,12) ='(5x,''*'',22x,''Joints triples'',22x,''*'')'
 139       texte(1,13) ='(5x,''*'',20x,''Joints quadruples'',19x,''*'')'
 140 c
 141       texte(2,5) ='(''Number of families :'',i8)'
 142       texte(2,6) = '(5x,''*'',22x,i1,''D'','' sub-domains'',21x,''*'')'
 143       texte(2,7) = '(5x,''*'',10x,''#'',20x,''*   '',a8,''   *'')'
 144       texte(2,11) ='(5x,''*'',20x,''Simple junctions'',21x,''*'')'
 145       texte(2,12) ='(5x,''*'',20x,''Triple junctions'',21x,''*'')'
 146       texte(2,13) ='(5x,''*'',19x,''Quadruple junctions'',19x,''*'')'
 147 c
 148 #include "impr03.h"
 149 c
 150 #ifdef _DEBUG_HOMARD_
 151       write (ulsort,90002) 'option', option
 152       write (ulsort,texte(langue,5)) nbfmed
 153       write (ulsort,90002) 'nbgrfm', nbgrfm
 154       write (ulsort,90002) 'famnbv', famnbv
 155 #endif
 156 c                    12345678
 157       mess08(1,0) = 'Nom     '
 158       mess08(1,1) = 'Longueur'
 159       mess08(1,2) = 'Surface '
 160       mess08(1,3) = 'Volume  '
 161 c
 162       mess08(2,0) = 'Name    '
 163       mess08(2,1) = 'Length  '
 164       mess08(2,2) = 'Surface '
 165       mess08(2,3) = 'Volume  '
 166 c
 167  1100 format(/,5x,59('*'))
 168  1101 format(  5x,59('*'))
 169 c
 170  1001 format(5x,'* ',a40,' * ',12x  ,' *')
 171  1002 format(5x,'* ',a40,' * ',g12.6,' *')
 172  1003 format(5x,'* Total :',34x,'* ',g12.6,' *')
 173  1004 format(5x,'* ',a3,'imum :',32x,'* ',g12.6,' *')
 174  1005 format(5x,'* ',a8,33x,'*  ',a8,'    *')
 175 c
 176       codret = 0
 177 c
 178       if ( famnbv.gt.0 ) then
 179 #ifdef _DEBUG_HOMARD_
 180       write (ulsort,91010) (famnum(iaux),iaux=1,famnbv)
 181       write (ulsort,92010) (famval(iaux),iaux=1,famnbv)
 182 #endif
 183 c
 184 c====
 185 c 2. impression de l'entete
 186 c====
 187 c
 188       write (ulbila,1100)
 189       if ( option.eq.1 ) then
 190         write (ulbila,texte(langue,6)) dimsd
 191       else
 192         write (ulbila,texte(langue,9+option))
 193       endif
 194       write (ulbila,1101)
 195 c
 196 c====
 197 c 3. parcours des groupes
 198 c====
 199 #ifdef _DEBUG_HOMARD_
 200       write (ulsort,90002) '3. parcours des groupes ; codret', codret
 201 #endif
 202 c
 203       imprgr = 0
 204 c
 205       nblign = 0
 206       vmin = famval(1)
 207       vmax = famval(1)
 208 c
 209       do 30 , iaux = 1 , nbgrfm
 210 c
 211 c 3.1. ==> Le nom du groupe
 212 c
 213         if ( codret.eq.0 ) then
 214 c
 215         lnogro = lgnogr(iaux)
 216         jaux = 10*(iaux-1) + 1
 217         call uts8ch ( nomgro(jaux), lnogro, saux80,
 218      >                ulsort, langue, codret )
 219 cgn        write(ulsort,90003) '. Groupe ', saux80(1:lnogro)
 220 c
 221         endif
 222 c
 223 c 3.2. ==> Les familles liees a ce groupe
 224 c
 225         if ( codret.eq.0 ) then
 226 c
 227 #ifdef _DEBUG_HOMARD_
 228         write (ulsort,texte(langue,3)) 'UTFMGR', nompro
 229 #endif
 230         call utfmgr ( saux80, nbfgro, lifagr,
 231      >                nbfmed, numfam,
 232      >                grfmpo, grfmtl, grfmtb,
 233      >                ulsort, langue, codret )
 234 #ifdef _DEBUG_HOMARD_
 235         write (ulsort,texte(langue,5)) nbfgro
 236         write (ulsort,91020) (lifagr(jaux), jaux=1,nbfgro)
 237 #endif
 238 c
 239         endif
 240 c
 241 c 3.3. ==> Cumul des tailles a partir des tailles des mailles
 242 c          par familles
 243 c
 244         if ( codret.eq.0 ) then
 245 c
 246         logaux = .false.
 247         daux = 0.d0
 248 c
 249         do 33 , jaux = 1 , nbfgro
 250 c
 251           do 331 , kaux = 1 , famnbv
 252             if ( famnum(kaux).eq.lifagr(jaux) ) then
 253               logaux = .true.
 254               daux = daux + famval(kaux)
 255             endif
 256   331     continue
 257 c
 258    33   continue
 259 c
 260         endif
 261 c
 262 c 3.3. ==> Impression eventuelle
 263 c
 264         if ( logaux ) then
 265 c
 266           if ( codret.eq.0 ) then
 267 c
 268           if ( imprgr.eq.0 ) then
 269             write (ulbila,1005) mess08(langue,0), mess08(langue,dimsd)
 270             write (ulbila,1101)
 271             imprgr = 1
 272           endif
 273 c
 274           if ( lnogro.gt.40 ) then
 275             write (ulbila,1001) saux80(1:40)
 276             jaux = 41
 277           else
 278             jaux = 1
 279           endif
 280           kaux = lnogro - jaux
 281           if ( kaux.eq.39 ) then
 282             write (ulbila,1002) saux80(jaux:lnogro), daux
 283           else
 284             write (ulbila,1002) saux80(jaux:lnogro)//blan64(1:40-kaux),
 285      >                          daux
 286           endif
 287 c
 288           vmin = min(vmin,daux)
 289           vmax = max(vmax,daux)
 290           nblign = nblign + 1
 291 c
 292           endif
 293 c
 294         endif
 295 c
 296    30 continue
 297 c
 298       if ( imprgr.eq.0 ) then
 299         write (ulbila,1005) blan08, mess08(langue,dimsd)
 300       endif
 301       write (ulbila,1101)
 302 c
 303 c====
 304 c 4. impression finale
 305 c====
 306 #ifdef _DEBUG_HOMARD_
 307       write (ulsort,90002) '4. impression finale ; codret', codret
 308 #endif
 309 c
 310       daux = 0.d0
 311       do 40 , iaux = 1 , famnbv
 312         daux = daux + famval(iaux)
 313    40 continue
 314 c
 315       if ( nblign.gt.2 ) then
 316         write (ulbila,1004) 'Min', vmin
 317         write (ulbila,1004) 'Max', vmax
 318         write (ulbila,1101)
 319       endif
 320       write (ulbila,1003) daux
 321       write (ulbila,1101)
 322 c
 323       endif
 324 c
 325       end