src/tool/Utilitaire/utb05b.F

   1       subroutine utb05b (  choix, typenh, nbeexa, quadia, qualij,
   2      >                    nbiter, rafdef, nbvoto, enqinf,
   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 - option 05 - etape b
  26 c    --           -              --         -
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . choix  . e   .    1   . variantes                                  .
  32 c .        .     .        .   0 : diametres                            .
  33 c .        .     .        .   1 : qualites                             .
  34 c .        .     .        .   2 : qualites par le jacobien normalise   .
  35 c . typenh . e   .    1   . variantes                                  .
  36 c .        .     .        .   2 : triangles                            .
  37 c .        .     .        .   3 : tetraedres                           .
  38 c .        .     .        .   4 : quadrangles                          .
  39 c .        .     .        .   5 : pyramides                            .
  40 c .        .     .        .   6 : hexaedres                            .
  41 c .        .     .        .   7 : pentaedres                           .
  42 c . nbeexa . e   .   1    . nombre d'entites a examiner                .
  43 c . quadia . e   . nbeexa . qualite/diametre des entites a examiner    .
  44 c . qualij . e   . nbeexa . qualite par le jacobien normalise          .
  45 c . nbiter . e   .   1    . numero de l'iteration courante             .
  46 c . rafdef . e   .   1    . histoire du maillage en raff/dera/modi     .
  47 c . nbvoto . e   .   1    . nombre de volumes                          .
  48 c . enqinf . e   .    *   . liste des entites de qualite infinie       .
  49 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  50 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  51 c . langue . e   .    1   . langue des messages                        .
  52 c .        .     .        . 1 : francais, 2 : anglais                  .
  53 c . codret .  s  .    1   . code de retour des modules                 .
  54 c .        .     .        . 0 : pas de probleme                        .
  55 c .        .     .        . 1 : probleme                               .
  56 c .____________________________________________________________________.
  57 c
  58 c====
  59 c 0. declarations et dimensionnement
  60 c====
  61 c
  62 c 0.1. ==> generalites
  63 c
  64       implicit none
  65       save
  66 c
  67       character*6 nompro
  68       parameter ( nompro = 'UTB05B' )
  69 c
  70 #include "nblang.h"
  71 c
  72 c 0.2. ==> communs
  73 c
  74 #include "envex1.h"
  75 c
  76 #include "enti01.h"
  77 #include "impr02.h"
  78 #include "precis.h"
  79 #include "infini.h"
  80 c
  81 c 0.3. ==> arguments
  82 c
  83       double precision quadia(*)
  84       double precision qualij(*)
  85       double precision valmin, valmax
  86 c
  87       integer choix, typenh, nbeexa
  88       integer nbiter, nbvoto
  89       integer enqinf(*)
  90 c
  91       integer ulbila, rafdef
  92       integer ulsort, langue, codret
  93 c
  94 c 0.4. ==> variables locales
  95 c
  96       integer lechoi, choide, choifi
  97       integer nbqinf
  98 c
  99       integer nbclmx
 100       parameter (nbclmx=50)
 101       integer histog(nbclmx)
 102       integer iclass(0:nbclmx)
 103       double precision rclass(0:nbclmx)
 104       integer nbclas
 105 c
 106       character*8 titcou(6)
 107       character*9 saux09
 108 c
 109       integer typval, ival(1)
 110       integer iaux, jaux, kaux
 111       integer nuroul, lnomfl
 112       integer difexp
 113       integer lgmess(nblang,0:2)
 114       integer nxmd58(nblang,7)
 115       integer nxmq58(nblang,7)
 116       integer nxmj58(nblang,7)
 117 c
 118       double precision xlow
 119       double precision vamiar, vamaar, valdif, difman, valech
 120       double precision daux, daux1
 121       double precision vmax, vmin
 122 c
 123       character*80 saux80, sau80a
 124       character*08 mess08(nblang,4)
 125       character*09 mess09(nblang,0:2)
 126       character*200 nomflo
 127 c
 128       integer nbmess
 129       parameter (nbmess = 10 )
 130       character*80 texte(nblang,nbmess)
 131       character*58 mege58(nblang,0:nbmess)
 132       character*58 medi58(nblang,nbmess,7)
 133       character*58 mequ58(nblang,nbmess,7)
 134       character*58 meqj58(nblang,nbmess,7)
 135 c
 136       logical consta
 137 c
 138 c 0.5. ==> initialisations
 139 c
 140       data typval / 2 /
 141       data xlow / 1.d0 /
 142 c ______________________________________________________________________
 143 c
 144 c====
 145 c 1. Messages
 146 c====
 147 c
 148 #include "impr01.h"
 149 c
 150 #ifdef _DEBUG_HOMARD_
 151       write (ulsort,texte(langue,1)) 'Entree', nompro
 152       call dmflsh (iaux)
 153 #endif
 154 c
 155 c 1.1. ==> Messages generaux
 156 c                    123456789
 157       mess09(1,0) = 'Diametre '
 158       mess09(1,1) = 'Qualite  '
 159       mess09(1,2) = 'Qualite  '
 160 c
 161       mess09(2,0) = 'Diameter '
 162       mess09(2,1) = 'Quality  '
 163       mess09(2,2) = 'Quality  '
 164 c
 165       texte(1,4) = '(''Nombre de '',a,'' a examiner : '',i8)'
 166       texte(1,5) = '(''--> valeur arrondie pour le '',a,'' :'',g15.6)'
 167       texte(1,6) = '(5x,''Nombre de '',a,'' aplatis : '',i8)'
 168       texte(1,7) = '(5x,''Le '',a,i10,'' est aplati.'')'
 169 c
 170       texte(2,4) = '(''Number of '',a,'' to be examined : '',i8)'
 171       texte(2,5) = '(''--> round value for '',a,'' :'',g15.6)'
 172       texte(2,6) = '(5x,''Number of flat '',a,'': '',i8)'
 173       texte(2,7) = '(5x,''The '',a,'' #'',i10,'' is flat.'')'
 174 c
 175 #include "impr03.h"
 176 c
 177 #ifdef _DEBUG_HOMARD_
 178       write (ulsort,90002) 'ulbila', ulbila
 179 #endif
 180 c
 181 c       1234567890123456789012345678901234567890123456789012345678
 182       mege58(1,0) =
 183      > 'DIAMETRES DES                                             '
 184       lgmess(1,0) = 13
 185       mege58(1,1) =
 186      > 'QUALITES DES                                              '
 187       lgmess(1,1) = 12
 188       mege58(1,2) =
 189      > 'QUALITES EN JACOBIEN NORMALISE DES                        '
 190       lgmess(1,2) = 34
 191       mege58(1,3) =
 192      > '            Valeur constante :                            '
 193       mege58(1,4) =
 194      > 'Remarque : on ne regarde ici que les triangles qui        '
 195       mege58(1,5) =
 196      > 'sont de vraies mailles de calcul.                         '
 197       mege58(1,6) =
 198      > 'Remarque : on ne regarde ici que les quadrangles qui      '
 199 c
 200       mege58(2,0) =
 201      > 'DIAMETERS OF                                              '
 202       lgmess(2,0) = 12
 203       mege58(2,1) =
 204      > 'QUALITY OF                                                '
 205       lgmess(2,1) = 10
 206       mege58(2,2) =
 207      > 'QUALITY WITH SCALED JACOBIAN OF                           '
 208       lgmess(2,2) = 31
 209       mege58(2,3) =
 210      > '              Constant value :                            '
 211       mege58(2,4) =
 212      > 'Remark : only triangles which are real calculation        '
 213       mege58(2,5) =
 214      > 'meshes are seen here.                                     '
 215       mege58(2,6) =
 216      > 'Remark : only quadrangles which are real calculation      '
 217 c
 218 c 1.2. ==> Messages lies aux diametres
 219 c
 220       medi58(1,1,1) =
 221      > 'Rappel : le diametre est egal a la longueur du plus       '
 222       medi58(1,2,1) =
 223      > 'grand segment que l''on peut tracer dans la maille.        '
 224 c
 225       medi58(1,1,2) =
 226      > 'Pour un triangle, c''est la longueur de la plus            '
 227       medi58(1,2,2) =
 228      > 'grande arete.                                             '
 229       nxmd58(1,2) = 2
 230 c
 231       medi58(1,1,3) =
 232      > 'Pour un tetraedre, c''est la longueur de la plus           '
 233       medi58(1,2,3) =
 234      > 'grande arete.                                             '
 235       nxmd58(1,3) = 2
 236 c
 237       medi58(1,1,4) =
 238      > 'Pour un quadrangle, c''est la plus grande longueur entre   '
 239       medi58(1,2,4) =
 240      > 'les aretes et les diagonales.                             '
 241       nxmd58(1,4) = 2
 242 c
 243       medi58(1,1,5) =
 244      > 'Pour une pyramide, c''est la plus grande longueur entre    '
 245       medi58(1,2,5) =
 246      > 'les aretes et les diagonales de la base.                  '
 247       nxmd58(1,5) = 2
 248 c
 249       medi58(1,1,6) =
 250      > 'Pour un hexaedre, c''est la plus grande longueur entre     '
 251       medi58(1,2,6) =
 252      > 'les aretes et les diagonales.                             '
 253       nxmd58(1,6) = 2
 254 c
 255       medi58(1,1,7) =
 256      > 'Pour un pentaedre, c''est la plus grande longueur entre    '
 257       medi58(1,2,7) =
 258      > 'les aretes et les diagonales.                             '
 259       nxmd58(1,7) = 2
 260 c
 261       medi58(2,1,1) =
 262      > 'Note: diameter egals the length of the largest line that  '
 263       medi58(2,2,1) =
 264      > 'can be placed in the mesh.                                '
 265 c
 266       medi58(2,1,2) =
 267      > 'For a triangle, it is the length of the largest edge.     '
 268       nxmd58(2,2) = 1
 269 c
 270       medi58(2,1,3) =
 271      > 'For a tetradron, it is the length of the largest edge.    '
 272       nxmd58(2,3) = 1
 273 c
 274       medi58(2,1,4) =
 275      > 'For a quadrangle, it is the largest length between edges  '
 276       medi58(2,2,4) =
 277      > 'and diagonals.                                            '
 278       nxmd58(2,4) = 2
 279 c
 280       medi58(2,1,5) =
 281      > 'For a pyramid, it is the largest length between edges     '
 282       medi58(2,2,5) =
 283      > 'and diagonals of the basis.                               '
 284       nxmd58(2,5) = 2
 285 c
 286       medi58(2,1,6) =
 287      > 'For an hexahedron, it is the largest length between edges '
 288       medi58(2,2,6) =
 289      > 'and diagonals.                                            '
 290       nxmd58(2,6) = 2
 291 c
 292       medi58(2,1,7) =
 293      > 'For a prism, it is the largest length between edges and   '
 294       medi58(2,2,7) =
 295      > 'diagonals of the basis.                                   '
 296       nxmd58(2,7) = 2
 297 c
 298 c 1.3. ==> Messages lies aux qualites
 299 c
 300       mequ58(1,1,2) =
 301      > 'Rappel : la qualite est egale au rapport du diametre du   '
 302       mequ58(1,2,2) =
 303      > 'triangle sur le rayon du cercle inscrit, normalise a 1    '
 304       mequ58(1,3,2) =
 305      > 'pour un triangle equilateral.                             '
 306       nxmq58(1,2) = 3
 307 c
 308       mequ58(1,1,3) =
 309      > 'Rappel : la qualite est egale au rapport du diametre du   '
 310       mequ58(1,2,3) =
 311      > 'tetraedre sur le rayon de la sphere inscrite,             '
 312       mequ58(1,3,3) =
 313      > 'normalise a 1 pour un tetraedre regulier.                 '
 314       nxmq58(1,3) = 3
 315 c
 316       mequ58(1,1,4) =
 317      > 'Rappel : la qualite est egale au rapport du produit de    '
 318       mequ58(1,2,4) =
 319      > 'la plus grande longueur des cotes et des diagonales et    '
 320       mequ58(1,3,4) =
 321      > 'de la moyenne quadratique des cotes sur la surface        '
 322       mequ58(1,4,4) =
 323      > 'minimum des triangles inscrits, normalise a 1 pour        '
 324       mequ58(1,5,4) =
 325      > 'pour un carre.                                            '
 326       nxmq58(1,4) = 5
 327 c
 328 c       123456789012345678901234567890123456789012345678901234
 329       mequ58(1,1,5) =
 330      > 'Non definie aujourd''hui.                                  '
 331       nxmq58(1,5) = 1
 332 c
 333       mequ58(1,1,6) =
 334      > 'Rappel : la qualite est egale a la qualite du pire des    '
 335       mequ58(1,2,6) =
 336      > '24 tetraedres composant l''hexaedre, normalise a 1         '
 337       mequ58(1,3,6) =
 338      > 'pour un cube.                                             '
 339       nxmq58(1,6) = 3
 340 c
 341       mequ58(1,1,7) =
 342      > 'Non definie aujourd''hui.                                  '
 343       nxmq58(1,7) = 1
 344 c
 345 c       1234567890123456789012345678901234567890123456789012345678
 346       mequ58(2,1,2) =
 347      > 'Note: the quality equals the ratio of the diametre        '
 348       mequ58(2,2,2) =
 349      > 'of the triangle by the radius of the inscribed circle     '
 350       mequ58(2,3,2) =
 351      > 'normalised to 1 for an equilateral triangle.              '
 352       nxmq58(2,2) = 3
 353 c
 354       mequ58(2,1,3) =
 355      > 'Note: the quality equals the ratio of the diametre        '
 356       mequ58(2,2,3) =
 357      > 'of the tetradron by the radius of the inscribed sphere    '
 358       mequ58(2,3,3) =
 359      > 'normalised to 1 for a regular tetrahedron.                '
 360       nxmq58(2,3) = 3
 361 c
 362       mequ58(2,1,4) =
 363      > 'Note: the quality equals the ratio of the product of      '
 364       mequ58(2,2,4) =
 365      > 'the largest edge and diagonals and square mean of edge    '
 366       mequ58(2,3,4) =
 367      > 'over minimum surface of inscribed triangles.              '
 368       mequ58(2,4,4) =
 369      > 'This valeur is normalised to 1 for a square.              '
 370       nxmq58(2,4) = 4
 371 c
 372       mequ58(2,1,5) =
 373      > 'Not available.                                            '
 374       nxmq58(2,5) = 1
 375 c
 376       mequ58(2,1,6) =
 377      > 'Note: the quality equals the worse quality of the         '
 378       mequ58(2,2,6) =
 379      > 'the 24 tetrahedron composing the hexahedron               '
 380       mequ58(2,3,6) =
 381      > 'normalised to 1 for a cube.                               '
 382       nxmq58(2,6) = 3
 383 c
 384       mequ58(2,1,7) =
 385      > 'Not available.                                            '
 386       nxmq58(2,7) = 1
 387 c
 388 c 1.4. ==> Messages lies aux qualites en jacobien normalise
 389 c
 390       meqj58(1,1,2) =
 391      > 'Rappel : la qualite est egale au minimum des Jacobiens    '
 392       meqj58(1,2,2) =
 393      > 'pour chacun des sommets, normalise a 1 pour               '
 394       meqj58(1,3,2) =
 395      > 'un triangle equilateral.                                  '
 396       nxmj58(1,2) = 3
 397 c
 398       meqj58(1,1,3) =
 399      > 'Rappel : la qualite est egale au minimum des Jacobiens    '
 400       meqj58(1,2,3) =
 401      > 'pour chacun des sommets, normalise a 1 pour               '
 402       meqj58(1,3,3) =
 403      > 'un tetraedre regulier.                                    '
 404       nxmj58(1,3) = 3
 405 c
 406       meqj58(1,1,4) =
 407      > 'Rappel : la qualite est egale au minimum des Jacobiens    '
 408       meqj58(1,2,4) =
 409      > 'pour chacun des sommets, normalise a 1 pour un carre.     '
 410       nxmj58(1,4) = 2
 411 c
 412       meqj58(1,1,5) =
 413      > 'Rappel : la qualite est egale au minimum des Jacobiens    '
 414       meqj58(1,2,5) =
 415      > 'pour chacun des sommets, normalise a 1 pour               '
 416       meqj58(1,3,5) =
 417      > 'une pyramide reguliere.                                   '
 418       nxmj58(1,5) = 3
 419 c
 420       meqj58(1,1,6) =
 421      > 'Rappel : la qualite est egale au minimum des Jacobiens    '
 422       meqj58(1,2,6) =
 423      > 'pour chacun des sommets, normalise a 1 pour un cube.      '
 424       nxmj58(1,6) = 2
 425 c
 426       meqj58(1,1,7) =
 427      > 'Rappel : la qualite est egale au minimum des Jacobiens    '
 428       meqj58(1,2,7) =
 429      > 'pour chacun des sommets, normalise a 1 pour               '
 430       meqj58(1,3,7) =
 431      > 'un pentaedre regulier.                                    '
 432       nxmj58(1,7) = 3
 433 c
 434 c       1234567890123456789012345678901234567890123456789012345678
 435       meqj58(2,1,2) =
 436      > 'Note: the quality equals the minimum of the Jacobian for  '
 437       meqj58(2,2,2) =
 438      > 'every node, normalised to 1 for an equilateral triangle.  '
 439       nxmj58(2,2) = 2
 440 c
 441       meqj58(2,1,3) =
 442      > 'Note: the quality equals the minimum of the Jacobian for  '
 443       meqj58(2,2,3) =
 444      > 'every node, normalised to 1 for a regular tetrahedron.    '
 445       nxmj58(2,3) = 2
 446 c
 447       meqj58(2,1,4) =
 448      > 'Note: the quality equals the minimum of the Jacobian for  '
 449       meqj58(2,2,4) =
 450      > 'every node, normalised to 1 for a square.                 '
 451       nxmj58(2,4) = 2
 452 c
 453       meqj58(2,1,5) =
 454      > 'Note: the quality equals the minimum of the Jacobian for  '
 455       meqj58(2,2,5) =
 456      > 'every node, normalised to 1 for a regular pyramid.        '
 457       nxmj58(2,5) = 2
 458 c
 459       meqj58(2,1,6) =
 460      > 'Note: the quality equals the minimum of the Jacobian for  '
 461       meqj58(2,2,6) =
 462      > 'every node, normalised to 1 for a cube.                   '
 463       nxmj58(2,6) = 2
 464 c
 465       meqj58(2,1,7) =
 466      > 'Note: the quality equals the minimum of the Jacobian for  '
 467       meqj58(2,2,7) =
 468      > 'every node, normalised to 1 for a regular prism.          '
 469       nxmj58(2,7) = 2
 470 c
 471 10100 format(/,5x,64('*'))
 472 10200 format(  5x,64('*'))
 473 11100 format(/,4x,a,/,4x,a)
 474 11200 format(  5x,'*  ',a58,'  *')
 475 c
 476       codret = 0
 477 c
 478 c====
 479 c 2. Initialisations
 480 c====
 481 c 2.1. ==> Recherche des types d'impressions a faire
 482 c
 483       if ( choix.eq.12 ) then
 484         choide = 1
 485         choifi = 2
 486       else
 487         choide = choix
 488         choifi = choix
 489       endif
 490 c
 491 c 2.2. ==> Valeurs extremes pour les aplatissements
 492 c
 493       vmax = 0.99d0 * vinfpo
 494       vmin = 1.11d0 * epsima
 495 c
 496       do 20 , lechoi = choide, choifi
 497 c
 498 #ifdef _DEBUG_HOMARD_
 499       write (ulsort,90002) 'lechoi', lechoi
 500 #endif
 501 c
 502 c====
 503 c 3. ecriture de l'entete
 504 c====
 505 c
 506       saux80 = mege58(langue,lechoi)
 507       iaux = lgmess(langue,lechoi) + 1
 508       saux80(iaux+1:iaux+14) = mess14(langue,5,typenh)
 509       call utlgut ( jaux, saux80,
 510      >              ulsort, langue, codret )
 511       do 31 , iaux = 1, jaux
 512         sau80a(iaux:iaux) = '-'
 513    31 continue
 514       write (ulbila,11100) saux80(1:jaux), sau80a(1:jaux)
 515 c
 516 c====
 517 c 4. les extremes
 518 c====
 519 c
 520 c 4.1. ==> Des entites sont aplaties
 521 c
 522       valmin = vinfpo
 523       valmax = vinfne
 524 c
 525       nbqinf = 0
 526 c
 527       if ( lechoi.le.1 ) then
 528 c
 529         do 411 , iaux = 1 , nbeexa
 530 cgn      write (ulsort,90114) 'quadia', iaux, quadia(iaux)
 531           if ( quadia(iaux).gt.vmin .and. quadia(iaux).lt.vmax ) then
 532             valmin = min ( valmin, quadia(iaux) )
 533             valmax = max ( valmax, quadia(iaux) )
 534           else
 535             nbqinf = nbqinf + 1
 536             enqinf(nbqinf) = iaux
 537           endif
 538   411   continue
 539 c
 540       else
 541 c
 542         do 412 , iaux = 1 , nbeexa
 543 cgn      write (ulsort,90114) 'qualij', iaux, qualij(iaux)
 544           if ( qualij(iaux).gt.vmin .and. qualij(iaux).lt.vmax ) then
 545             valmin = min ( valmin, qualij(iaux) )
 546             valmax = max ( valmax, qualij(iaux) )
 547           else
 548             nbqinf = nbqinf + 1
 549             enqinf(nbqinf) = iaux
 550           endif
 551   412   continue
 552 c
 553       endif
 554 c
 555 #ifdef _DEBUG_HOMARD_
 556       write (ulsort,texte(langue,4)) mess14(langue,3,typenh), nbeexa
 557 cgn      if ( lechoi.ne.1 ) then
 558       write (ulsort,90004) mess09(langue,lechoi)//'min', valmin
 559 cgn      endif
 560       write (ulsort,90004) mess09(langue,lechoi)//'max', valmax
 561 #endif
 562 c
 563 c 4.2. ==> Des entites sont aplaties
 564 c
 565       if ( nbqinf.gt.0 ) then
 566 c
 567       write (ulbila,texte(langue,6)) mess14(langue,3,typenh), nbqinf
 568       do 42 , iaux = 1 , nbqinf
 569         write (ulbila,texte(langue,7)) mess14(langue,1,typenh),
 570      >                                 enqinf(iaux)
 571    42 continue
 572 c
 573       endif
 574 c
 575 c 4.3. ==> Est-ce constant ?
 576 c
 577       if ( valmax.le.epsima ) then
 578         consta = .true.
 579       else
 580         if ( (valmax-valmin)/valmax.le.1.d-6 ) then
 581           consta = .true.
 582         else
 583           consta = .false.
 584         endif
 585       endif
 586 #ifdef _DEBUG_HOMARD_
 587       write (ulsort,99001) 'consta', consta
 588 #endif
 589 c
 590 c====
 591 c 5. arrondis des valeurs extremes
 592 c====
 593 #ifdef _DEBUG_HOMARD_
 594       write (ulsort,90002) '5. arrondis ; codret', codret
 595 #endif
 596 c
 597       if ( .not.consta ) then
 598 c
 599 c 5.1. ==> Programme de calcul des arrondis
 600 c
 601       if ( codret.eq.0 ) then
 602 c
 603 #ifdef _DEBUG_HOMARD_
 604       write (ulsort,texte(langue,3)) 'UTARRO', nompro
 605 #endif
 606       call utarro ( valmin, valmax, vamiar, vamaar,
 607      >              ulsort, langue, codret )
 608 c
 609       endif
 610 c
 611 c 5.2. ==> Ajustement en fonction du traitement
 612 c
 613       if ( codret.eq.0 ) then
 614 c
 615 #ifdef _DEBUG_HOMARD_
 616       write (ulsort,90004) 'Arrondi min', vamiar
 617       write (ulsort,90004) 'Arrondi max', vamaar
 618 #endif
 619 c
 620       if ( lechoi.eq.0 .or. lechoi.eq.2 ) then
 621         vamiar = max(vamiar,0.d0)
 622       elseif ( lechoi.eq.1 ) then
 623         vamiar = max(vamiar,1.d0)
 624       endif
 625 c
 626       if ( lechoi.eq.2 ) then
 627         vamaar = min(vamaar,1.d0)
 628       endif
 629 c
 630 #ifdef _DEBUG_HOMARD_
 631       write (ulsort,90004) 'Arrondi min final', vamiar
 632       write (ulsort,90004) 'Arrondi max final', vamaar
 633 #endif
 634 c
 635       endif
 636 c
 637       endif
 638 c
 639 c====
 640 c 6. Creation des classes
 641 c====
 642 #ifdef _DEBUG_HOMARD_
 643       write (ulsort,90002) '6. Creation des classes ; codret', codret
 644 #endif
 645 c
 646       if ( .not.consta ) then
 647 c
 648 c 6.1 ==> Gestion de l'ordre de grandeur
 649 c         C'est un probleme qui se pose pour le diametre en fonction des
 650 c         unites qui ont ete utilisees.
 651 c
 652       if ( codret.eq.0 ) then
 653 c
 654       valdif = ( vamaar - vamiar ) * 0.99999999d0
 655 c
 656 #ifdef _DEBUG_HOMARD_
 657       write (ulsort,texte(langue,3)) 'UTPD10', nompro
 658 #endif
 659       call utpd10 ( valdif, difman, difexp,
 660      >              ulsort, langue, codret )
 661 #ifdef _DEBUG_HOMARD_
 662       write (ulsort,90004) 'valdif', valdif
 663       write (ulsort,90004) '==> difman', difman
 664       write (ulsort,90002) '==> difexp', difexp
 665 #endif
 666 c
 667       endif
 668 c
 669       if ( codret.eq.0 ) then
 670 c
 671       if ( difexp.le.0 ) then
 672         valech = 10.d0**(1-difexp)
 673       elseif ( difexp.ge.4 ) then
 674         valech = 10.d0**(2-difexp)
 675       else
 676         valech = 1.d0
 677       endif
 678       daux = valdif*valech
 679 #ifdef _DEBUG_HOMARD_
 680       write (ulsort,90004) 'valech', valech
 681       write (ulsort,90004) 'daux=valdif*valech', daux
 682 #endif
 683 c
 684       endif
 685 c
 686 c 6.2 ==> Les classes
 687 c
 688       if ( codret.eq.0 ) then
 689 c
 690       if ( daux.le.1.d0 ) then
 691 c
 692         nbclas = 20
 693         daux1 = 0.05d0/valech
 694 c
 695       elseif ( daux.le.2.d0 ) then
 696 c
 697         nbclas = 40
 698         daux1 = 0.05d0/valech
 699 c
 700       elseif ( daux.le.2.5d0 ) then
 701 c
 702         nbclas = 50
 703         daux1 = 0.05d0/valech
 704 c
 705       elseif ( daux.le.4.d0 ) then
 706 c
 707         nbclas = 40
 708         daux1 = 0.10d0/valech
 709 c
 710       elseif ( daux.le.5.d0 ) then
 711 c
 712         nbclas = 50
 713         daux1 = 0.10d0/valech
 714 c
 715       elseif ( daux.le.7.5d0 ) then
 716 c
 717         nbclas = 30
 718         daux1 = 0.25d0/valech
 719 c
 720       elseif ( daux.le.10.d0 ) then
 721 c
 722         nbclas = 40
 723         daux1 = 0.25d0/valech
 724 c
 725       elseif ( daux.le.15.d0 ) then
 726 c
 727         nbclas = 30
 728         daux1 = 0.50d0/valech
 729 c
 730       elseif ( daux.le.20.d0 ) then
 731 c
 732         nbclas = 40
 733         daux1 = 0.50d0/valech
 734 c
 735       elseif ( daux.le.50.d0 ) then
 736 c
 737         nbclas = 25
 738         daux1 = 2.00d0/valech
 739 c
 740       elseif ( daux.le.100.d0 ) then
 741 c
 742         nbclas = 50
 743         daux1 = 2.00d0/valech
 744 c
 745       else
 746 c
 747         nbclas = nbclmx
 748         daux1 = (vamaar-vamiar) / dble(nbclas)
 749 c
 750       endif
 751 c
 752 #ifdef _DEBUG_HOMARD_
 753       write (ulsort,90002) 'nbclas', nbclas
 754       write (ulsort,90004) 'daux1', daux1
 755 #endif
 756       rclass(0) = vamiar
 757       do 62 , iaux = 1 , nbclas
 758         rclass(iaux) = rclass(iaux-1) + daux1
 759         if ( rclass(iaux).ge.vamaar ) then
 760           jaux = iaux
 761           goto 620
 762         endif
 763    62 continue
 764       jaux = nbclas
 765   620 continue
 766       nbclas = jaux
 767 c
 768       endif
 769 c
 770 #ifdef _DEBUG_HOMARD_
 771       do 6999 , iaux = 0 , nbclas
 772         write (ulsort,90114) 'rclass', iaux, rclass(iaux)
 773  6999 continue
 774 #endif
 775 c
 776       endif
 777 c
 778 c====
 779 c 7. ecriture sur le fichier d'information
 780 c====
 781 #ifdef _DEBUG_HOMARD_
 782       write (ulsort,90002) '7. ecriture ; codret', codret
 783 #endif
 784 c 7.1. ==> ecriture de l'entete
 785 c
 786       if ( codret.eq.0 ) then
 787 c
 788       write (ulbila,10100)
 789 c
 790       if ( lechoi.eq.0 ) then
 791 c
 792         write (ulbila,11200) medi58(langue,1,1)
 793         write (ulbila,11200) medi58(langue,2,1)
 794         do 710 , iaux = 1, nxmd58(langue,typenh)
 795           write (ulbila,11200) medi58(langue,iaux,typenh)
 796   710   continue
 797 c
 798       elseif ( lechoi.eq.1 ) then
 799 c
 800         do 711 , iaux = 1, nxmq58(langue,typenh)
 801           write (ulbila,11200) mequ58(langue,iaux,typenh)
 802   711   continue
 803 c
 804       else
 805 c
 806         do 712 , iaux = 1, nxmj58(langue,typenh)
 807           write (ulbila,11200) meqj58(langue,iaux,typenh)
 808   712   continue
 809 c
 810       endif
 811 c
 812       if ( nbvoto.ne.0 ) then
 813         if ( typenh.eq.2 .or. typenh.eq.4 ) then
 814           write (ulbila,11200) mege58(langue,typenh+2)
 815           write (ulbila,11200) mege58(langue,5)
 816         endif
 817       endif
 818 c
 819       endif
 820 c
 821 c 7.2. ==> message si constant
 822 c
 823       if ( codret.eq.0 ) then
 824 c
 825       if ( consta ) then
 826 c
 827         write (ulbila,10200)
 828         write (mege58(langue,3)(32:42),'(f11.4)') valmin
 829         write (ulbila,11200) mege58(langue,3)
 830         write (ulbila,10200)
 831 c
 832       endif
 833 c
 834       endif
 835 c
 836 c====
 837 c 8. sortie pour xmgrace et ecriture de la table
 838 c====
 839 #ifdef _DEBUG_HOMARD_
 840       write (ulsort,90002) '8. ecriture ; codret', codret
 841 #endif
 842 c
 843       if ( .not.consta ) then
 844 c
 845 c 8.1. ==> Ouverture du fichier
 846 c
 847       if ( codret.eq.0 ) then
 848 c
 849       if ( lechoi.eq.0 ) then
 850         saux09 = 'diam.'//suffix(2,typenh)(1:4)
 851       elseif ( lechoi.eq.1 ) then
 852         saux09 = 'qual.'//suffix(2,typenh)(1:4)
 853       else
 854         saux09 = 'quaj.'//suffix(2,typenh)(1:4)
 855       endif
 856       iaux = 2
 857       jaux = -1
 858       if ( rafdef.eq.31 ) then
 859         kaux = 1
 860       else
 861         kaux = nbiter
 862       endif
 863 #ifdef _DEBUG_HOMARD_
 864       write (ulsort,texte(langue,3)) 'UTULBI', nompro
 865 #endif
 866       call utulbi ( nuroul, nomflo, lnomfl,
 867      >                iaux, saux09, kaux, jaux,
 868      >              ulsort, langue, codret )
 869 #ifdef _DEBUG_HOMARD_
 870       write (ulsort,90003) 'nomflo', nomflo
 871 #endif
 872 c
 873       endif
 874 c
 875 c 8.2. ==> Ecriture
 876 c
 877       if ( codret.eq.0 ) then
 878 c
 879       mess08(1,2) = ' des '//mess14(langue,3,typenh)(1:3)
 880       mess08(1,3) = mess14(langue,3,typenh)(4:11)
 881       mess08(1,4) = mess14(langue,3,typenh)(12:13)//'     '
 882 c
 883       mess08(2,2) = ' of '//mess14(langue,3,typenh)(1:4)
 884       mess08(2,3) = mess14(langue,3,typenh)(5:12)
 885       mess08(2,4) = mess14(langue,3,typenh)(13:14)//'      '
 886 c
 887       titcou(1) = mess09(langue,lechoi)(1:8)
 888       titcou(2) = mess08(langue,2)
 889       titcou(3) = mess08(langue,3)
 890       titcou(4) = mess08(langue,4)
 891       titcou(5) = titcou(1)
 892 c
 893       iaux = nuroul
 894       if ( lechoi.le.1 ) then
 895 #ifdef _DEBUG_HOMARD_
 896         write (ulsort,texte(langue,3)) 'UTCRHI / quadia', nompro
 897 #endif
 898         call utcrhi ( nbclas, rclass, iclass, histog,
 899      >                nbeexa, typval, quadia, ival,
 900      >                titcou, xlow, ulbila, iaux,
 901      >                ulsort, langue, codret )
 902       else
 903 #ifdef _DEBUG_HOMARD_
 904         write (ulsort,texte(langue,3)) 'UTCRHI / qualij', nompro
 905 #endif
 906         call utcrhi ( nbclas, rclass, iclass, histog,
 907      >                nbeexa, typval, qualij, ival,
 908      >                titcou, xlow, ulbila, iaux,
 909      >                ulsort, langue, codret )
 910         endif
 911 c
 912       endif
 913 c
 914 c 8.3. ==> Fermeture du fichier
 915 c
 916       if ( codret.eq.0 ) then
 917 c
 918       call gufeul ( nuroul , codret)
 919 c
 920       endif
 921 c
 922       endif
 923 c
 924    20 continue
 925 c
 926 c====
 927 c 9. la fin
 928 c====
 929 c
 930       if ( codret.ne.0 ) then
 931 c
 932 #include "envex2.h"
 933 c
 934       write (ulsort,texte(langue,1)) 'Sortie', nompro
 935       write (ulsort,texte(langue,2)) codret
 936 c
 937       endif
 938 c
 939 #ifdef _DEBUG_HOMARD_
 940       write (ulsort,texte(langue,1)) 'Sortie', nompro
 941       call dmflsh (iaux)
 942 #endif
 943 c
 944       end