1 subroutine uttris ( seuil,
3 > fracti, nbval, valeur,
4 > ulsort, langue, codret)
5 c ______________________________________________________________________
9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
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
17 c HOMARD est une marque deposee d'Electricite de France
23 c ______________________________________________________________________
25 c UTilitaire - TRI d'un tableau reel pour un Seuil
27 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 ______________________________________________________________________
47 c 0. declarations et dimensionnement
50 c 0.1. ==> generalites
56 parameter ( nompro = 'UTTRIS' )
71 double precision seuil, fracti, valeur(nbval)
73 integer ulsort, langue, codret
75 c 0.4. ==> variables locales
77 integer iaux, jaux, kaux
78 integer numero, nombre, nbvtri
80 double precision daux, daux1
83 parameter ( nbmess = 20 )
84 character*80 texte(nblang,nbmess)
86 c 0.5. ==> initialisations
87 c ______________________________________________________________________
96 write (ulsort,texte(langue,1)) 'Entree', nompro
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.'')'
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.'')'
122 #ifdef _DEBUG_HOMARD_
123 write (ulsort,texte(langue,4))
124 write (ulsort,texte(langue,5)) nbval
125 write (ulsort,texte(langue,6)) fracti
132 c 2.1. ==> controle du type de recherche
134 if ( typtri.lt.1 .or. typtri.gt.2 ) then
138 #ifdef _DEBUG_HOMARD_
139 if ( typtri.eq.1 ) then
140 write (ulsort,texte(langue,8))
142 write (ulsort,texte(langue,9))
146 cgn print 88,(valeur(iaux),iaux =1,nbval)
147 cgn 88 format(12g10.3)
149 c 2.2. ==> nombre de valeurs a traiter
151 if ( codret.eq.0 ) then
153 c 2.2.1. ==> Si 1 seule entite, le cas est particulier
155 if ( nbval.eq.1 ) then
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
164 c si on a au moins deux valeurs, on ajoute 1, sauf si on est
167 nbvtri = nint(fracti*dble(nbval)/100.d0)
169 if ( nbvtri.ge.2 ) then
170 nbvtri = min(nbvtri+1,nbval)
173 #ifdef _DEBUG_HOMARD_
174 write (ulsort,texte(langue,7)) nbvtri
182 c 3. calcul du seuil pour les grandes valeurs
185 if ( codret.eq.0 ) then
187 if ( typtri.eq.1 ) then
189 if ( nbvtri.eq.0 ) then
191 c 3.1. ==> Si 0 entite, le seuil est au dessus du maximum
194 do 311 , iaux = 1 , nbval
195 daux = max(daux,valeur(iaux))
198 #ifdef _DEBUG_HOMARD_
199 write (ulsort,texte(langue,11))
202 elseif ( nbvtri.eq.1 ) then
204 c 3.2. ==> Si 1 entite, le seuil est juste au-dessous du maximum
208 do 321 , iaux = 2 , nbval
209 if ( abs(valeur(iaux)-daux).gt.epsima ) then
210 daux1 = min(daux1,abs(valeur(iaux)-daux))
212 daux = max(daux,valeur(iaux))
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
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
231 do 331 , iaux = 1 , nbval
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
239 cgn print *,valeur(iaux),daux,(valeur(classt(jaux)), jaux =1,nombre)
240 if ( valeur(iaux).gt.daux .or. nombre.lt.nbvtri ) then
242 do 3311 , jaux = 1 , nombre
243 if ( valeur(classt(jaux)).lt.valeur(iaux) ) then
249 if ( nombre.eq.nbvtri ) then
257 cgn print *,'goto 331'
262 c 3.3.2. ==> insertion de l'element courant a la bonne place
266 cgn print *,'numero = ',numero
268 if ( nombre.eq.nbvtri ) then
273 do 3313 , jaux = kaux, numero, -1
274 classt(jaux+1) = classt(jaux)
277 classt(numero) = iaux
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))
284 if ( nombre.lt.nbvtri ) then
287 daux = valeur(classt(nombre))
288 cgn print *,daux,nombre
292 c 3.3.4. ==> le seuil est entre la valeur correspondant au pourcentage
293 c d'element et celle immediatement superieure
295 cgn print *,valeur(classt(nbvtri-1))
296 cgn print *,valeur(classt(nbvtri))
298 > (valeur(classt(nbvtri-1))+valeur(classt(nbvtri)))
303 c 4. calcul du seuil pour les faibles valeurs
308 if ( nbvtri.eq.0 ) then
310 c 4.1. ==> Si 0 entite, le seuil est au dessous du minimum
313 do 411 , iaux = 1 , nbval
314 daux = min(daux,valeur(iaux))
318 elseif ( nbvtri.eq.1 ) then
320 c 4.2. ==> Si 1 entite, le seuil est juste au-dessus du minimum
324 do 421 , iaux = 2 , nbval
325 if ( abs(valeur(iaux)-daux).gt.epsima ) then
326 daux1 = min(daux1,abs(valeur(iaux)-daux))
328 daux = min(daux,valeur(iaux))
330 seuil = daux + 0.5d0*daux1
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
342 do 431 , iaux = 1 , nbval
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
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
354 do 4311 , jaux = 1 , nombre
355 if ( valeur(classt(jaux)).gt.valeur(iaux) ) then
361 if ( nombre.eq.nbvtri ) then
369 cgn print *,'goto 431'
374 c 4.3.2. ==> insertion de l'element courant a la bonne place
378 cgn print *,'numero = ',numero
380 if ( nombre.eq.nbvtri ) then
385 do 4313 , jaux = kaux, numero, -1
386 classt(jaux+1) = classt(jaux)
389 classt(numero) = iaux
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))
396 if ( nombre.lt.nbvtri ) then
399 daux = valeur(classt(nombre))
400 cgn print *,daux,nombre
404 c 4.3.4. ==> le seuil est entre la valeur correspondant au pourcentage
405 c d'element et celle immediatement inferieure
407 cgn print *,valeur(classt(nbvtri-1))
408 cgn print *,valeur(classt(nbvtri))
410 > (valeur(classt(nbvtri-1))+valeur(classt(nbvtri)))
422 #ifdef _DEBUG_HOMARD_
423 write(ulsort,texte(langue,10)) seuil
426 if ( codret.ne.0 ) then
430 write (ulsort,texte(langue,1)) 'Sortie', nompro
431 write (ulsort,texte(langue,2)) codret
435 #ifdef _DEBUG_HOMARD_
436 write (ulsort,texte(langue,1)) 'Sortie', nompro