src/tool/Utilitaire/utcrhi.F

   1       subroutine utcrhi ( nbclas, rclass, iclass, histog,
   2      >                    nbval,  typval,   rval,   ival,
   3      >                    titcou, xlow, ulbila, ulxmgr,
   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 - CReation d'un HIstogramme
  26 c    --           --            --
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . nbclas . e   .   1    . nombre de classes a affecter               .
  32 c . rclass . e   .0:nbclas. limites des classes si reel                .
  33 c . iclass . e   .0:nbclas. limites des classes si entier              .
  34 c . histog .   s . nbclas . histogramme resultant                      .
  35 c . nbval  . e   .   1    . nombre de valeurs a classer                .
  36 c . typval . e   .   1    . 1 : valeurs entieres                       .
  37 c .        .     .        . 2 : valeurs reelles                        .
  38 c . rval   . e   . nbval  . valeurs reelles a classer                  .
  39 c . ival   . e   . nbval  . valeurs entieres a classer                 .
  40 c . titcou . e   . char*8 . titre des courbes                          .
  41 c . xlow   . e   .   1    . limite basse pour les valeurs              .
  42 c . ulbila . e   .   1    . unite logique d'ecriture du bilan          .
  43 c . ulxmgr . e   .   1    . unite logique pour le fichier xmgrace      .
  44 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  45 c . langue . e   .    1   . langue des messages                        .
  46 c .        .     .        . 1 : francais, 2 : anglais                  .
  47 c . codret .  s  .    1   . code de retour des modules                 .
  48 c .        .     .        . 0 : pas de probleme                        .
  49 c .        .     .        . 1 : probleme                               .
  50 c .____________________________________________________________________.
  51 c
  52 c====
  53 c 0. declarations et dimensionnement
  54 c====
  55 c
  56 c 0.1. ==> generalites
  57 c
  58       implicit none
  59       save
  60 c
  61       character*6 nompro
  62       parameter ( nompro = 'UTCRHI' )
  63 c
  64 #include "nblang.h"
  65 c
  66 c 0.2. ==> communs
  67 c
  68 #include "envex1.h"
  69 c
  70 c 0.3. ==> arguments
  71 c
  72       integer nbclas, nbval, typval
  73       integer iclass(0:nbclas), histog(nbclas)
  74       integer ival(*)
  75 c
  76       double precision rclass(0:nbclas)
  77       double precision rval(*)
  78       double precision xlow
  79 c
  80       integer ulbila, ulxmgr
  81       integer ulsort, langue, codret
  82 c
  83       character*8 titcou(*)
  84 c
  85 c 0.4. ==> variables locales
  86 c
  87       integer iaux, jaux
  88       integer ivamax, ivamin
  89       integer p10max, p10min, p10dec
  90       integer nrocou
  91 c
  92       real raux, raux1
  93       real x1, x2, y1, y2
  94 c
  95       double precision rvamax, rvamin, epsilo, val10
  96       double precision rvamoy, rvecty
  97 c
  98       logical prem
  99       logical ecart
 100 c
 101       integer nbmess
 102       parameter (nbmess = 10 )
 103       character*80 texte(nblang,nbmess)
 104       character*58 mess58(nblang,nbmess)
 105 c
 106 c 0.5. ==> initialisations
 107 c ______________________________________________________________________
 108 c
 109 c====
 110 c 1. initialisations
 111 c====
 112 c
 113 #include "impr01.h"
 114 c
 115 #ifdef _DEBUG_HOMARD_
 116       write (ulsort,texte(langue,1)) 'Entree', nompro
 117       call dmflsh (iaux)
 118 #endif
 119 c
 120       texte(1,4) = '(''Nombre de classes : '',i8)'
 121       texte(1,5) = '(''Nombre de valeurs a classer   : '',i8)'
 122       texte(1,6) = '(''Limite basse pour les valeurs :'',g15.6)'
 123       texte(1,7) = '(''Classe'',i3,'' : '',g25.7)'
 124 c
 125       texte(2,4) = '(''Number of classes : '',i8)'
 126       texte(2,5) = '(''Number of values to sort : '',i8)'
 127       texte(2,6) = '(''Low limit for values :'',g15.6)'
 128       texte(2,7) = '(''Class'',i3,'' : '',g25.7)'
 129 c
 130 #include "impr03.h"
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133       write (ulsort,texte(langue,4)) nbclas
 134       write (ulsort,texte(langue,5)) nbval
 135       write (ulsort,texte(langue,6)) xlow
 136       do 1100 , iaux = 0 , nbclas
 137         write (ulsort,texte(langue,7)) iaux, rclass(iaux)
 138  1100 continue
 139 #endif
 140 c
 141 c       1234567890123456789012345678901234567890123456789012345678
 142       mess58(1,1) =
 143      > '                  Fonction de repartition                 '
 144       mess58(1,2) =
 145      > '    Valeurs        *          Nombre de mailles           '
 146       mess58(1,3) =
 147      > '  Mini <  < Maxi   *    par classe     *      cumul       '
 148       mess58(1,4) =
 149      > '                   * en %  .  nombre   *  en %  .  nombre '
 150 c       123458789012345678901234567890123456789012345678901234
 151 c
 152       mess58(2,1) =
 153      > '                 Fonction of repartition                  '
 154       mess58(2,2) =
 155      > '    Values        *           Number of meshes            '
 156       mess58(2,3) =
 157      > '  Mini <  < Maxi  *     per class      *      total       '
 158       mess58(2,4) =
 159      > '                  *  in %  .  number   *  in %  .  number '
 160 c
 161 10200 format(  5x,64('*'))
 162 c
 163 11100 format(5x,'*  ',a58,'  *')
 164 c
 165 13101 format(
 166      >5x,'*   Minimum : ',i11,  '        Maximum : ',i15,  '     *')
 167 13102 format(
 168      >5x,'*   Minimum : ',g12.5,'           Maximum : ',g12.5,'    *')
 169 13103 format(
 170      >5x,'*   Moyenne : ',g12.5,'        Ecart-type : ',g12.5,'    *')
 171 13203 format(
 172      >5x,'*   Mean    : ',g12.5,'     Std deviation : ',g12.5,'    *')
 173 c
 174 21200 format(
 175      >  '@map font 0 to "Helvetica", "Helvetica"',
 176      >/,'@map color 1 to (0, 0, 0), "black"',
 177      >/,'@map color 2 to (255, 0, 0), "red"',
 178      >/,'@map color 4 to (0, 0, 255), "blue"')
 179 c
 180 21210 format(
 181      >  '#',
 182      >/,'@    title "',4a8,'"',
 183      >/,'@    title font 0',
 184      >/,'@    title size 1.00000',
 185      >/,'@    title color 4')
 186 21220 format(
 187      >  '#',
 188      >/,'@with g',i1)
 189 21230 format(
 190      >  '@    s0 type XY',
 191      >/,'@    s0 skip 0',
 192      >/,'@    s0 linestyle 1',
 193      >/,'@    s0 linewidth 1',
 194      >/,'@    s0 color 2',
 195      >/,'@    s0 fill 6',
 196      >/,'@    s0 fill color 2')
 197 21240 format(
 198      >  '@    world xmin ',g12.5,
 199      >/,'@    xaxis  bar color 2',
 200      >/,'@    xaxis  bar linestyle 1',
 201      >/,'@    xaxis  bar linewidth 1.0',
 202      >/,'@    xaxis  label "',a,'"',
 203      >/,'@    xaxis  label char size 0.80',
 204      >/,'@    xaxis  label font 0',
 205      >/,'@    xaxis  label color 4',
 206      >/,'@    xaxis  ticklabel font 0',
 207      >/,'@    xaxis  ticklabel char size 0.8')
 208 21241 format(
 209      >  '@    yaxis  bar color 2',
 210      >/,'@    yaxis  bar linestyle 1',
 211      >/,'@    yaxis  bar linewidth 1.0',
 212      >/,'@    yaxis  label "Pourcentage de mailles"',
 213      >/,'@    yaxis  label char size 0.80',
 214      >/,'@    yaxis  label font 0',
 215      >/,'@    yaxis  label color 4',
 216      >/,'@    yaxis  ticklabel font 0',
 217      >/,'@    yaxis  ticklabel char size 0.8')
 218 21250 format(1x,g13.7,3x,g13.7)
 219 c
 220 21260 format(5x,
 221      >'* ',f8.3,' < ',f8.3,' *',f6.2,' .',i10,' *',f7.2,' .',i10,' *')
 222 21261 format(5x,
 223      >'* ',g8.3,' < ',g8.3,' *',f6.2,' .',i10,' *',f7.2,' .',i10,' *')
 224 21262 format(5x,
 225      >'*', f9.2,' <', f9.2,' *',f6.2,' .',i10,' *',f7.2,' .',i10,' *')
 226 21263 format(5x,
 227      >'*', g9.2,' <', g9.2,' *',f6.2,' .',i10,' *',f7.2,' .',i10,' *')
 228 21270 format(5x,
 229      >'* ',f8.3,' <  inf.    *',f6.2,' .',i10,' * 100.00 .',i10,' *')
 230 21280 format(
 231      >  '#',
 232      >/,'@g',i1,' on')
 233 c
 234 c 1.2. ==> variables locales
 235 c
 236       codret = 0
 237 c
 238       if ( ulxmgr.gt.0 ) then
 239         prem = .true.
 240       elseif ( ulxmgr.lt.0 ) then
 241         prem = .false.
 242         ulxmgr = - ulxmgr
 243       else
 244         codret = 1
 245       endif
 246 c
 247 c====
 248 c 2. classement
 249 c===
 250 #ifdef _DEBUG_HOMARD_
 251       write (ulsort,90002) '2. classement ; codret', codret
 252 #endif
 253 c
 254       if ( codret.eq.0 ) then
 255 c
 256 c 2.1. ==> preparation du classement
 257 c
 258       do 21 , jaux = 1 , nbclas
 259         histog(jaux) = 0
 260    21 continue
 261 c
 262 c 2.2. ==> recherche des extrema et rangement des valeurs en entier
 263 c
 264       if ( typval.eq.1 ) then
 265 c
 266         ivamin = ival(1)
 267         ivamax = ival(1)
 268 c
 269         do 22 , iaux = 1 , nbval
 270 c
 271           ivamin = min ( ivamin , ival(iaux) )
 272           ivamax = max ( ivamax , ival(iaux) )
 273 c
 274           do 221 , jaux = 1 , nbclas
 275             if ( ival(iaux).ge.iclass(jaux-1) .and.
 276      >           ival(iaux).lt.iclass(jaux) ) then
 277               histog(jaux) = histog(jaux) + 1
 278               goto 222
 279             endif
 280   221     continue
 281 c
 282   222     continue
 283 c
 284    22   continue
 285 c
 286         p10min = 0
 287         p10max = 0
 288 c
 289 c 2.3. ==> recherche des extrema et rangement des valeurs en reel
 290 c          on elargit temporairement les bornes inferieure, rclass(0),
 291 c          et superieure, rclass(nbclas), pour etre certain de ne rien
 292 c          rater dans le classement.
 293 c
 294       elseif ( typval.eq.2 ) then
 295 c
 296         epsilo = 1.d-5*(rclass(nbclas)-rclass(0))
 297         rclass(0) = rclass(0) - epsilo
 298         rclass(nbclas) = rclass(nbclas) + epsilo
 299 c
 300         rvamin = rval(1)
 301         rvamax = rval(1)
 302         rvamoy = 0.d0
 303         rvecty = 0.d0
 304 c
 305         do 23 , iaux = 1 , nbval
 306 c
 307           rvamin = min ( rvamin , rval(iaux) )
 308           rvamax = max ( rvamax , rval(iaux) )
 309           rvamoy = rvamoy + rval(iaux)
 310           rvecty = rvecty + rval(iaux)**2
 311 c
 312           do 231 , jaux = 1 , nbclas
 313             if ( rval(iaux).ge.rclass(jaux-1) .and.
 314      >           rval(iaux).lt.rclass(jaux) ) then
 315               histog(jaux) = histog(jaux) + 1
 316               goto 232
 317             endif
 318   231     continue
 319 c
 320   232     continue
 321 c
 322    23   continue
 323 c
 324         rvamoy = rvamoy / dble(nbval)
 325         rvecty = sqrt ( rvecty/ dble(nbval) - rvamoy**2 )
 326 #ifdef _DEBUG_HOMARD_
 327         write (ulsort,90004) 'rvamin', rvamin
 328         write (ulsort,90004) 'rvamax', rvamax
 329         write (ulsort,90004) 'rvamoy', rvamoy
 330         write (ulsort,90004) 'rvecty', rvecty
 331 #endif
 332 c
 333         rclass(0) = rclass(0) + epsilo
 334         rclass(nbclas) = rclass(nbclas) - epsilo
 335 c
 336 #ifdef _DEBUG_HOMARD_
 337       write (ulsort,texte(langue,3)) 'UTPD10', nompro
 338 #endif
 339         call utpd10 ( rclass(0), val10, p10min,
 340      >                ulsort, langue, codret )
 341 #ifdef _DEBUG_HOMARD_
 342       write (ulsort,90024) 'rclass', 0, rclass(0)
 343       write (ulsort,*) '=> val10  =', val10, ', p10min =', p10min
 344 #endif
 345 c
 346         if ( codret.eq.0 ) then
 347 #ifdef _DEBUG_HOMARD_
 348       write (ulsort,texte(langue,3)) 'UTPD10', nompro
 349 #endif
 350         call utpd10 ( rclass(nbclas), val10, p10max,
 351      >                ulsort, langue, codret )
 352 #ifdef _DEBUG_HOMARD_
 353       write (ulsort,90024) 'rclass', nbclas, rclass(nbclas)
 354       write (ulsort,*) '=> val10       =', val10, ', p10max =', p10max
 355 #endif
 356         endif
 357 c
 358 c 2.4. ==> erreur sinon
 359 c
 360       else
 361 c
 362         codret = 1
 363 c
 364       endif
 365 c
 366       endif
 367 c
 368 c====
 369 c 3. Impression sur la sortie standard et sur un fichier
 370 c    a exploiter par xmgrace
 371 c====
 372 #ifdef _DEBUG_HOMARD_
 373       write (ulsort,90002) '3. Impression ; codret', codret
 374 #endif
 375 c
 376       if ( codret.eq.0 ) then
 377 c
 378       nrocou = 0
 379 c
 380       write (ulbila,10200)
 381       if ( typval.eq.1 ) then
 382         write (ulbila,13101) ivamin, ivamax
 383         p10dec = 0
 384       else
 385         write (ulbila,13102) dble(rvamin), dble(rvamax)
 386         if ( langue.eq.1 ) then
 387           write (ulbila,13103) dble(rvamoy), dble(rvecty)
 388         else
 389           write (ulbila,13203) dble(rvamoy), dble(rvecty)
 390         endif
 391         if ( p10max.lt.0 .or. p10max.gt.3 ) then
 392           p10dec = p10max-1
 393         elseif ( p10max.eq.0 .and. p10min.lt.-1 ) then
 394           p10dec = p10min-2
 395         else
 396           p10dec = 0
 397         endif
 398 #ifdef _DEBUG_HOMARD_
 399       write (ulsort,90015) 'p10max', p10max, ', p10min', p10min
 400       write (ulsort,90002) '==> p10dec', p10dec
 401 #endif
 402         if ( p10dec.ne.0 ) then
 403           mess58(langue,4)(4:9) = '* 10**'
 404           if ( p10dec.le.-100 ) then
 405             write (mess58(langue,4)(10:13),'(i4)') p10dec
 406           elseif ( p10dec.le.-10 ) then
 407             write (mess58(langue,4)(10:12),'(i3)') p10dec
 408           elseif ( p10dec.le.-1 ) then
 409             write (mess58(langue,4)(10:11),'(i2)') p10dec
 410           elseif ( p10dec.le.9 ) then
 411             write (mess58(langue,4)(10:10),'(i1)') p10dec
 412           elseif ( p10dec.le.99 ) then
 413             write (mess58(langue,4)(10:11),'(i2)') p10dec
 414           else
 415             write (mess58(langue,4)(10:13),'(i4)') p10dec
 416           endif
 417         endif
 418         if ( abs(p10max-p10min).le.3 ) then
 419           ecart = .true.
 420         else
 421           ecart = .false.
 422         endif
 423 #ifdef _DEBUG_HOMARD_
 424         write (ulsort,99001) 'ecart', ecart
 425 #endif
 426       endif
 427       write (ulbila,10200)
 428 c
 429       write (ulbila,11100) mess58(langue,1)
 430       write (ulbila,11100) mess58(langue,2)
 431       write (ulbila,11100) mess58(langue,3)
 432       write (ulbila,11100) mess58(langue,4)
 433       write (ulbila,10200)
 434 c
 435       if ( ulxmgr.ne.ulbila ) then
 436         if ( prem ) then
 437           write (ulxmgr,21200)
 438           write (ulxmgr,21210) (titcou(iaux), iaux = 1 , 4 )
 439           write (ulxmgr,21220) nrocou
 440           write (ulxmgr,21230)
 441           write (ulxmgr,21240) xlow, titcou(5)
 442           write (ulxmgr,21241)
 443           write (ulxmgr,21280) nrocou
 444         endif
 445       endif
 446 c
 447       if ( typval.eq.1 ) then
 448         x2 = real(iclass(0))
 449       else
 450         x2 = real(rclass(0))
 451       endif
 452       if ( ulxmgr.ne.ulbila ) then
 453         write (ulxmgr,21250) x2, 0.
 454       endif
 455       raux1 = x2
 456 cgn      write (ulsort,90004) 'raux1', raux1
 457 c
 458       iaux= 0
 459       raux = 100. / real(nbval)
 460       do 31 , jaux = 1 , nbclas
 461         x1 = x2
 462         y1 = real(histog(jaux)) * raux
 463         if ( typval.eq.1 ) then
 464           x2 = real(iclass(jaux))
 465         else
 466           x2 = real(rclass(jaux))
 467         endif
 468         iaux = iaux + histog(jaux)
 469         y2 = real(iaux) * raux
 470         if ( raux1.ge.0. ) then
 471           if ( ecart ) then
 472             write (ulbila,21260)
 473      >            x1*10.**(-p10dec), x2*10.**(-p10dec),
 474      >            y1, histog(jaux), y2, iaux
 475           else
 476             write (ulbila,21261)
 477      >            x1*10.**(-p10dec), x2*10.**(-p10dec),
 478      >            y1, histog(jaux), y2, iaux
 479           endif
 480         else
 481           if ( ecart ) then
 482             write (ulbila,21262)
 483      >            x1*10.**(-p10dec), x2*10.**(-p10dec),
 484      >            y1, histog(jaux), y2, iaux
 485           else
 486             write (ulbila,21263)
 487      >            x1*10.**(-p10dec), x2*10.**(-p10dec),
 488      >            y1, histog(jaux), y2, iaux
 489           endif
 490         endif
 491         if ( ulxmgr.ne.ulbila ) then
 492           write (ulxmgr,21250) x1, y1
 493           write (ulxmgr,21250) x2, y1
 494         endif
 495    31 continue
 496       if ( ulxmgr.ne.ulbila ) then
 497         write (ulxmgr,21250) x2, 0.
 498       endif
 499 c
 500       if ( iaux.lt.nbval ) then
 501 c
 502         iaux = nbval - iaux
 503         y1 = real(iaux) * raux
 504         write (ulbila,21270) x2*10.**(-p10dec), y1, iaux, nbval
 505 c
 506       endif
 507 c
 508       write (ulbila,10200)
 509 c
 510       endif
 511 c
 512 c====
 513 c 4. la fin
 514 c====
 515 c
 516       if ( codret.ne.0 ) then
 517 c
 518 #include "envex2.h"
 519 c
 520       write (ulsort,texte(langue,1)) 'Sortie', nompro
 521       write (ulsort,texte(langue,2)) codret
 522 c
 523       endif
 524 c
 525 #ifdef _DEBUG_HOMARD_
 526       write (ulsort,texte(langue,1)) 'Sortie', nompro
 527       call dmflsh (iaux)
 528 #endif
 529 c
 530       end
 531 ctest      program toto
 532 ctest       implicit none
 533 ctest      integer nbclas, nbval, typval
 534 ctest      parameter (nbclas=30)
 535 ctest      parameter (nbval=100)
 536 ctestc
 537 ctest      integer iclass(0:nbclas), histog(nbclas)
 538 ctest      double precision rclass(0:nbclas)
 539 ctest      double precision xlow
 540 ctest      double precision rval(nbval)
 541 ctest      integer ival(nbval)
 542 ctestc
 543 ctest      integer ulbila, ulxmgr
 544 ctest      integer ulsort, langue, codret
 545 ctest      character*8 titcou(10)
 546 ctestc
 547 ctest      integer n
 548 ctest      rclass(0) = 1.d0
 549 ctest      do 2111 , n = 1 , 10
 550 ctest         rclass(n) = rclass(n-1) + 0.1d0
 551 ctest 2111 continue
 552 ctest      do 2112 , n = 11 , 26
 553 ctest         rclass(n) = rclass(n-1) + 0.5d0
 554 ctest 2112 continue
 555 ctest      rclass(27) = 15.d0
 556 ctest      rclass(28) = 20.d0
 557 ctest      rclass(29) = 50.d0
 558 ctest      rclass(30) = 100.d0
 559 ctestc
 560 ctest      typval = 2
 561 ctest      langue = 1
 562 ctest      ulbila = 41
 563 ctest      ulxmgr = 42
 564 ctest      ulsort = 6
 565 ctest      xlow = 1.d0
 566 ctest      do 12 ,n=1,nbval
 567 ctest        rval(n) = 1.d0 + dble(n)/10.d0
 568 ctest  12  continue
 569 ctest      titcou(1) = '12345678'
 570 ctest      titcou(2) = '9 ... 16'
 571 ctest      titcou(3) = '17 .. 24'
 572 ctest      titcou(4) = '25... 32'
 573 ctest      titcou(5) = '33      '
 574 ctest      titcou(7) = '49      '
 575 ctest      titcou(8) = '57... 64'
 576 ctest      titcou(9) = '65... 72'
 577 ctestc
 578 ctest      call utcrhi ( nbclas, rclass, iclass, histog,
 579 ctest     >                    nbval,  typval,   rval,   ival,
 580 ctest     >                    titcou, xlow, ulbila, ulxmgr,
 581 ctest     >                    ulsort, langue, codret )
 582 ctestc
 583 ctest      end