src/tool/Utilitaire/uttris.F

   1       subroutine uttris ( seuil,
   2      >                    typtri, classt,
   3      >                    fracti, nbval, valeur,
   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 - TRI d'un tableau reel pour un Seuil
  26 c    --           ---                           -
  27 c ______________________________________________________________________
  28 c .        .     .        .                                            .
  29 c .  nom   . e/s . taille .           description                      .
  30 c .____________________________________________________________________.
  31 c . seuil  .   s .   1    . seuil correspondant                        .
  32 c . typtri . e   .   1    . 1 : grandes valeurs                        .
  33 c .        .     .        . 2 : faibles valeurs                        .
  34 c . fracti . e   .   1    . pourcentage d'entites a retenir            .
  35 c . classt .  s  . nbval  . tableau auxiliaire                         .
  36 c . nbval  . e   .   1    . nombre de valeurs a traiter                .
  37 c . valeur . e   . nbval  . liste des valeurs a ranger                 .
  38 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  39 c . langue . e   .    1   . langue des messages                        .
  40 c .        .     .        . 1 : francais, 2 : anglais                  .
  41 c . codret . es  .    1   . code de retour des modules                 .
  42 c .        .     .        . 0 : pas de probleme                        .
  43 c .        .     .        . 1 : probleme                               .
  44 c ______________________________________________________________________
  45 c
  46 c====
  47 c 0. declarations et dimensionnement
  48 c====
  49 c
  50 c 0.1. ==> generalites
  51 c
  52       implicit none
  53       save
  54 c
  55       character*6 nompro
  56       parameter ( nompro = 'UTTRIS' )
  57 c
  58 #include "nblang.h"
  59 c
  60 c 0.2. ==> communs
  61 c
  62 #include "envex1.h"
  63 #include "infini.h"
  64 #include "precis.h"
  65 c
  66 c 0.3. ==> arguments
  67 c
  68       integer typtri, nbval
  69       integer classt(nbval)
  70 c
  71       double precision seuil, fracti, valeur(nbval)
  72 c
  73       integer ulsort, langue, codret
  74 c
  75 c 0.4. ==> variables locales
  76 c
  77       integer iaux, jaux, kaux
  78       integer numero, nombre, nbvtri
  79 c
  80       double precision daux, daux1
  81 c
  82       integer nbmess
  83       parameter ( nbmess = 20 )
  84       character*80 texte(nblang,nbmess)
  85 c
  86 c 0.5. ==> initialisations
  87 c ______________________________________________________________________
  88 c
  89 c====
  90 c 1. messages
  91 c====
  92 c
  93 #include "impr01.h"
  94 c
  95 #ifdef _DEBUG_HOMARD_
  96       write (ulsort,texte(langue,1)) 'Entree', nompro
  97       call dmflsh (iaux)
  98 #endif
  99 c
 100       texte(1,4) = '(''Recherche du seuil'')'
 101       texte(1,5) = '(''Nombre de valeurs a trier :'',i12)'
 102       texte(1,6) = '(''Pourcentage demande :'',g13.7)'
 103       texte(1,7) = '(''==> Nombre d''''entites :'',i12)'
 104       texte(1,8) = '(''Tri sur les grandes valeurs'')'
 105       texte(1,9) = '(''Tri sur les faibles valeurs'')'
 106       texte(1,10) = '(''Seuil :'',g13.7)'
 107       texte(1,11) = '(''Le pourcentage d''''entites est trop faible.'')'
 108       texte(1,12) = '(''Une seule valeur a trier.'')'
 109 c
 110       texte(2,4) = '(''Sort of a real array'')'
 111       texte(2,5) = '(''Number of valeurs to sort :'',i12)'
 112       texte(2,6) = '(''Requested percentage :'',g13.7)'
 113       texte(2,7) = '(''==> Number of entities :'',i12)'
 114       texte(2,8) = '(''Sort for large values'')'
 115       texte(2,9) = '(''Sort for small values'')'
 116       texte(2,10) = '(''Threshold :'',g13.7)'
 117       texte(2,11) = '(''Requested percentage is too small.'')'
 118       texte(2,12) = '(''A unique value to sort.'')'
 119 c
 120 #include "impr03.h"
 121 c
 122 #ifdef _DEBUG_HOMARD_
 123       write (ulsort,texte(langue,4))
 124       write (ulsort,texte(langue,5)) nbval
 125       write (ulsort,texte(langue,6)) fracti
 126 #endif
 127 c
 128 c====
 129 c 2. Prealable
 130 c====
 131 c
 132 c 2.1. ==> controle du type de recherche
 133 c
 134       if ( typtri.lt.1 .or. typtri.gt.2 ) then
 135         codret = 1
 136       else
 137         codret = 0
 138 #ifdef _DEBUG_HOMARD_
 139         if ( typtri.eq.1 ) then
 140           write (ulsort,texte(langue,8))
 141         else
 142           write (ulsort,texte(langue,9))
 143         endif
 144 #endif
 145       endif
 146 cgn       print 88,(valeur(iaux),iaux =1,nbval)
 147 cgn 88    format(12g10.3)
 148 c
 149 c 2.2. ==> nombre de valeurs a traiter
 150 c
 151       if ( codret.eq.0 ) then
 152 c
 153 c 2.2.1. ==> Si 1 seule entite, le cas est particulier
 154 c
 155       if ( nbval.eq.1 ) then
 156 c
 157         nbvtri = 1
 158 c
 159       else
 160 c
 161 c 2.2.2. ==> Avec au moins deux entites, on cherche le nombre
 162 c            correspondant au pourcentage demande par l'entier le plus
 163 c            proche.
 164 c            si on a au moins deux valeurs, on ajoute 1, sauf si on est
 165 c            deja au maximum.
 166
 167         nbvtri = nint(fracti*dble(nbval)/100.d0)
 168 c
 169         if ( nbvtri.ge.2 ) then
 170           nbvtri = min(nbvtri+1,nbval)
 171         endif
 172 c
 173 #ifdef _DEBUG_HOMARD_
 174       write (ulsort,texte(langue,7)) nbvtri
 175 #endif
 176 c
 177       endif
 178 c
 179       endif
 180 c
 181 c====
 182 c 3. calcul du seuil pour les grandes valeurs
 183 c====
 184 c
 185       if ( codret.eq.0 ) then
 186 c
 187       if ( typtri.eq.1 ) then
 188 c
 189         if ( nbvtri.eq.0 ) then
 190 c
 191 c 3.1. ==> Si 0 entite, le seuil est au dessus du maximum
 192 c
 193           daux = vinfne
 194           do 311 , iaux = 1 , nbval
 195             daux = max(daux,valeur(iaux))
 196   311     continue
 197           seuil = 2.d0 * daux
 198 #ifdef _DEBUG_HOMARD_
 199       write (ulsort,texte(langue,11))
 200 #endif
 201 c
 202         elseif ( nbvtri.eq.1 ) then
 203 c
 204 c 3.2. ==> Si 1 entite, le seuil est juste au-dessous du maximum
 205 c
 206           daux = valeur(1)
 207           daux1 = vinfpo
 208           do 321 , iaux = 2 , nbval
 209             if ( abs(valeur(iaux)-daux).gt.epsima ) then
 210               daux1 = min(daux1,abs(valeur(iaux)-daux))
 211             endif
 212             daux = max(daux,valeur(iaux))
 213   321     continue
 214 cgn            print 88,daux,daux1
 215           seuil = daux - 0.5d0*daux1
 216 #ifdef _DEBUG_HOMARD_
 217       write (ulsort,texte(langue,12))
 218       write (ulsort,90004) 'seuil', seuil
 219 #endif
 220 c
 221         else
 222 c
 223 c 3.3. ==> cas general
 224 c          on stocke dans le tableau classt les indices des valeurs les
 225 c          plus grandes. L'indice 1 correspond a la plus grande valeur
 226 c          et ainsi de suite.
 227 c
 228           nombre = 0
 229           daux = vinfne
 230 c
 231           do 331 , iaux = 1 , nbval
 232 c
 233 c 3.3.1. ==> si la valeur courante est plus grande que le mini des
 234 c            valeurs deja classees, ou si on n'a pas encore classe au
 235 c            moins nbvtri valeurs, il faut l'inserer dans le tableau.
 236 c            on recherche la valeur juste inferieure
 237 c            sinon, on passe a la valeur suivante
 238 c
 239 cgn       print *,valeur(iaux),daux,(valeur(classt(jaux)), jaux =1,nombre)
 240             if ( valeur(iaux).gt.daux .or. nombre.lt.nbvtri ) then
 241 c
 242               do 3311 , jaux = 1 , nombre
 243                 if ( valeur(classt(jaux)).lt.valeur(iaux) ) then
 244                   numero = jaux
 245                   goto 3312
 246                 endif
 247  3311         continue
 248 c
 249               if ( nombre.eq.nbvtri ) then
 250                 numero = nbvtri
 251               else
 252                 numero = nombre + 1
 253               endif
 254 c
 255             else
 256 c
 257 cgn              print *,'goto 331'
 258               goto 331
 259 c
 260             endif
 261 c
 262 c 3.3.2. ==> insertion de l'element courant a la bonne place
 263 c            dans la liste
 264 c
 265  3312       continue
 266 cgn            print *,'numero = ',numero
 267 c
 268             if ( nombre.eq.nbvtri ) then
 269               kaux = nbvtri - 1
 270             else
 271               kaux = nombre
 272             endif
 273             do 3313 , jaux = kaux, numero, -1
 274               classt(jaux+1) = classt(jaux)
 275  3313       continue
 276 c
 277             classt(numero) = iaux
 278 c
 279 c 3.3.3. ==> nombre de valeurs classees : une de plus qu'avant, sauf si
 280 c            on a deja classe toutes celles voulues.
 281 c            Il ne faut surtout pas tout classer sinon c'est extremement
 282 c            couteux (en o(n**2))
 283 c
 284             if ( nombre.lt.nbvtri ) then
 285               nombre = nombre + 1
 286             endif
 287             daux = valeur(classt(nombre))
 288 cgn            print *,daux,nombre
 289 c
 290   331     continue
 291 c
 292 c 3.3.4. ==> le seuil est entre la valeur correspondant au pourcentage
 293 c            d'element et celle immediatement superieure
 294 c
 295 cgn      print *,valeur(classt(nbvtri-1))
 296 cgn      print *,valeur(classt(nbvtri))
 297           seuil = 0.5d0*
 298      >           (valeur(classt(nbvtri-1))+valeur(classt(nbvtri)))
 299 c
 300         endif
 301 c
 302 c====
 303 c 4. calcul du seuil pour les faibles valeurs
 304 c====
 305 c
 306       else
 307 c
 308         if ( nbvtri.eq.0 ) then
 309 c
 310 c 4.1. ==> Si 0 entite, le seuil est au dessous du minimum
 311 c
 312           daux = vinfpo
 313           do 411 , iaux = 1 , nbval
 314             daux = min(daux,valeur(iaux))
 315   411     continue
 316           seuil = 0.5d0 * daux
 317 c
 318         elseif ( nbvtri.eq.1 ) then
 319 c
 320 c 4.2. ==> Si 1 entite, le seuil est juste au-dessus du minimum
 321 c
 322           daux = valeur(1)
 323           daux1 = vinfpo
 324           do 421 , iaux = 2 , nbval
 325             if ( abs(valeur(iaux)-daux).gt.epsima ) then
 326               daux1 = min(daux1,abs(valeur(iaux)-daux))
 327             endif
 328             daux = min(daux,valeur(iaux))
 329   421     continue
 330           seuil = daux + 0.5d0*daux1
 331 c
 332         else
 333 c
 334 c 4.3. ==> cas general
 335 c          on stocke dans le tableau classt les indices des valeurs les
 336 c          plus grandes. L'indice 1 correspond a la plus petite valeur
 337 c          et ainsi de suite.
 338 c
 339           nombre = 0
 340           daux = vinfpo
 341 c
 342           do 431 , iaux = 1 , nbval
 343 c
 344 c 4.3.1. ==> si la valeur courante est plus petite que le maxi des
 345 c            valeurs deja classees, ou si on n'a pas encore classe au
 346 c            moins nbvtri valeurs, il faut l'inserer dans le tableau.
 347 c            on recherche la valeur juste superieure
 348 c            sinon, on passe a la valeur suivante
 349 c
 350 cgn       print 88,valeur(iaux),daux,(valeur(classt(jaux)),jaux =1,nombre)
 351 cgn 88    format(12g10.3)
 352             if ( valeur(iaux).lt.daux .or. nombre.lt.nbvtri ) then
 353 c
 354               do 4311 , jaux = 1 , nombre
 355                 if ( valeur(classt(jaux)).gt.valeur(iaux) ) then
 356                   numero = jaux
 357                   goto 4312
 358                 endif
 359  4311         continue
 360 c
 361               if ( nombre.eq.nbvtri ) then
 362                 numero = nbvtri
 363               else
 364                 numero = nombre + 1
 365               endif
 366 c
 367             else
 368 c
 369 cgn              print *,'goto 431'
 370               goto 431
 371 c
 372             endif
 373 c
 374 c 4.3.2. ==> insertion de l'element courant a la bonne place
 375 c            dans la liste
 376 c
 377  4312       continue
 378 cgn            print *,'numero = ',numero
 379 c
 380             if ( nombre.eq.nbvtri ) then
 381               kaux = nbvtri - 1
 382             else
 383               kaux = nombre
 384             endif
 385             do 4313 , jaux = kaux, numero, -1
 386               classt(jaux+1) = classt(jaux)
 387  4313       continue
 388 c
 389             classt(numero) = iaux
 390 c
 391 c 4.3.3. ==> nombre de valeurs classees : une de plus qu'avant, sauf si
 392 c            on a deja classe toutes celles voulues.
 393 c            Il ne faut surtout pas tout classer sinon c'est extremement
 394 c            couteux (en o(n**2))
 395 c
 396             if ( nombre.lt.nbvtri ) then
 397               nombre = nombre + 1
 398             endif
 399             daux = valeur(classt(nombre))
 400 cgn            print *,daux,nombre
 401 c
 402   431     continue
 403 c
 404 c 4.3.4. ==> le seuil est entre la valeur correspondant au pourcentage
 405 c            d'element et celle immediatement inferieure
 406 c
 407 cgn      print *,valeur(classt(nbvtri-1))
 408 cgn      print *,valeur(classt(nbvtri))
 409           seuil = 0.5d0*
 410      >           (valeur(classt(nbvtri-1))+valeur(classt(nbvtri)))
 411 c
 412         endif
 413 c
 414       endif
 415 c
 416       endif
 417 c
 418 c====
 419 c 5. la fin
 420 c====
 421 c
 422 #ifdef _DEBUG_HOMARD_
 423       write(ulsort,texte(langue,10)) seuil
 424 #endif
 425 c
 426       if ( codret.ne.0 ) then
 427 c
 428 #include "envex2.h"
 429 c
 430       write (ulsort,texte(langue,1)) 'Sortie', nompro
 431       write (ulsort,texte(langue,2)) codret
 432 c
 433       endif
 434 c
 435 #ifdef _DEBUG_HOMARD_
 436       write (ulsort,texte(langue,1)) 'Sortie', nompro
 437       call dmflsh (iaux)
 438 #endif
 439 c
 440       end