src/tool/Utilitaire/utcte4.F

   1       subroutine utcte4 ( option, nborig, tborig,
   2      >                    tbconv,
   3      >                    tbaux1, classt,
   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 - Conversion de Tableau Entier - action 4
  26 c    --           -             -       -               -
  27 c
  28 c   On retourne un tableau entier qui contient :
  29 c   . soit 0 si le critere n'est pas satisfait,
  30 c   . soit le rang correspondant si le critere est satisfait
  31 c    . si option = 1 : on retient les valeurs non nulles
  32 c    . si option = 2 : on retient les valeurs strictement positives
  33 c    . si option = 3 : on retient les valeurs strictement negatives
  34 c
  35 c Exemples : tableau d'origine : (  0, 13,  0, -1,  4, -3,  0,  1 )
  36 c
  37 c  option  1 : ordonne les valeurs non nulles
  38 c            tableau converti  : (  0,  5,  0,  2,  4,  1,  0,  3)
  39 c  option  2 : ordonne les valeurs > 0
  40 c            tableau converti  : (  0,  3,  0,  0,  2,  0,  0,  1)
  41 c  option  3 : ordonne les valeurs < 0
  42 c            tableau converti  : (  0,  0,  0,  2,  0,  1,  0,  0)
  43 c
  44 c remarque : l'action elle-meme est faite ici
  45 c            on peut enrober ce traitement par utcte2, pour gerer
  46 c            des allocations de tableau
  47 c ______________________________________________________________________
  48 c .        .     .        .                                            .
  49 c .  nom   . e/s . taille .           description                      .
  50 c .____________________________________________________________________.
  51 c . option . e   .    1   . option de la conversion                    .
  52 c .        .     .        . option = 1 : les valeurs non nulles   .
  53 c .        .     .        . option = 2 : les valeurs > 0          .
  54 c .        .     .        . option = 3 : les valeurs < 0          .
  55 c .        .     .        . option > 0 : rang dans le tableau initial  .
  56 c .        .     .        . option < 0 : numero d'apparition           .
  57 c . nborig . e   .    1   . nombre de valeurs dasn le tableau original .
  58 c . tborig . e   . nborig . tableau original a convertir               .
  59 c . tbconv .   s . nborig . tableau converti                           .
  60 c . tbaux1 . aux . nborig . tableau auxiliaire 1                       .
  61 c . classt . aux . nborig . tableau auxiliaire 2                       .
  62 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  63 c . langue . e   .    1   . langue des messages                        .
  64 c .        .     .        . 1 : francais, 2 : anglais                  .
  65 c . codret . es  .    1   . code de retour des modules                 .
  66 c .        .     .        . 0 : pas de probleme                        .
  67 c .        .     .        . -1 : mauvaise demande pour le type de nom  .
  68 c .        .     .        . -2 : mauvaise demande pour l'option        .
  69 c .        .     .        . -3 : probleme sur le tableau a convertir   .
  70 c .        .     .        . autre : probleme dans l'allocation         .
  71 c ______________________________________________________________________
  72 c
  73 c====
  74 c 0. declarations et dimensionnement
  75 c====
  76 c
  77 c 0.1. ==> generalites
  78 c
  79       implicit none
  80       save
  81 c
  82       character*6 nompro
  83       parameter ( nompro = 'UTCTE4' )
  84 c
  85 #include "nblang.h"
  86 c
  87 c 0.2. ==> communs
  88 c
  89 #include "envex1.h"
  90 c
  91 c 0.3. ==> arguments
  92 c
  93       integer option
  94       integer nborig
  95       integer tborig(nborig), tbconv(nborig)
  96       integer tbaux1(nborig), classt(nborig)
  97 c
  98       integer ulsort, langue, codret
  99 c
 100 c 0.4. ==> variables locales
 101 c
 102       integer iaux, jaux, kaux
 103       integer vmin, vmax
 104       integer nbvalm, nbvalp
 105 c
 106       integer nbmess
 107       parameter ( nbmess = 10 )
 108       character*80 texte(nblang,nbmess)
 109 c
 110 c 0.5. ==> initialisations
 111 c ______________________________________________________________________
 112 c
 113 c====
 114 c 1. messages
 115 c====
 116 c
 117 #include "impr01.h"
 118 c
 119 #ifdef _DEBUG_HOMARD_
 120       write (ulsort,texte(langue,1)) 'Entree', nompro
 121       call dmflsh (iaux)
 122 #endif
 123 c
 124       texte(1,4) = '(''Option :'',i4)'
 125       texte(1,5) = '(''Mauvaise demande d''''option :'',i8)'
 126       texte(1,6) =
 127      >'(''Tableau '',a,'', de'',i13,'' a'',i13,'' : '',5i13,/,50x,5i13)'
 128       texte(1,7) = '(''Nombre de valeurs '',a,'' : '',i13)'
 129       texte(1,8) = '(''Valeur '',a,'' : '',i13)'
 130 c
 131       texte(2,4) = '(''Option :'',i4)'
 132       texte(2,5) = '(''Bad request for the option :'',i8)'
 133       texte(2,6) =
 134      >'(''Array '',a,'', from'',i13,'' to'',i13,'' :'',5i13,/,49x,5i13)'
 135       texte(2,7) = '(''Number of values '',a,'' : '',i13)'
 136       texte(2,8) = '(''Value '',a,'' : '',i13)'
 137 c
 138 #ifdef _DEBUG_HOMARD_
 139       write (ulsort,texte(langue,4)) option
 140 #endif
 141 c
 142       codret = 0
 143 c
 144 #ifdef _DEBUG_HOMARD_
 145       iaux = min(nborig,10)
 146       write (ulsort,texte(langue,6)) 'initial', 1, iaux,
 147      >            (tborig(jaux),jaux=1,iaux)
 148       if ( nborig.gt.10 ) then
 149         write (ulsort,texte(langue,6)) 'initial', nborig-iaux+1,nborig,
 150      >              (tborig(iaux),iaux=nborig-iaux+1,nborig)
 151       endif
 152 #endif
 153 c
 154 c====
 155 c 2. creation du tableau epure
 156 c====
 157 c
 158       nbvalm = 0
 159       nbvalp = 0
 160 c
 161 c 2.0. ==> mise a zero par defaut
 162 c
 163       do 20 , iaux = 1 , nborig
 164         tbaux1(iaux) = 0
 165    20 continue
 166 c
 167 c 2.1. ==> on considere toutes les valeurs non nulles
 168 c
 169       if ( option.eq.1 ) then
 170 c
 171         do 21 , iaux = 1 , nborig
 172 c
 173           if ( tborig(iaux).lt.0 ) then
 174             nbvalm = nbvalm + 1
 175             tbaux1(iaux) = tborig(iaux)
 176           elseif ( tborig(iaux).gt.0 ) then
 177             nbvalp = nbvalp + 1
 178             tbaux1(iaux) = tborig(iaux)
 179           endif
 180 c
 181    21   continue
 182 c
 183 c 2.2. ==> on considere toutes les valeurs non nulles et positives
 184 c
 185       elseif ( option.eq.2 ) then
 186 c
 187         do 22 , iaux = 1 , nborig
 188 c
 189           if ( tborig(iaux).gt.0 ) then
 190             nbvalp = nbvalp + 1
 191             tbaux1(iaux) = tborig(iaux)
 192           endif
 193 c
 194    22   continue
 195 c
 196 c 2.3. ==> on considere toutes les valeurs non nulles et positives
 197 c
 198       elseif ( option.eq.3 ) then
 199 c
 200         do 23 , iaux = 1 , nborig
 201 c
 202           if ( tborig(iaux).lt.0 ) then
 203             nbvalm = nbvalm + 1
 204             tbaux1(iaux) = tborig(iaux)
 205           endif
 206 c
 207    23   continue
 208 c
 209 c 2.4. ==> erreur
 210 c
 211       else
 212 c
 213         codret = -2
 214 c
 215       endif
 216 c
 217 #ifdef _DEBUG_HOMARD_
 218       if ( option.eq.1 .or. option.eq.3 ) then
 219       write (ulsort,texte(langue,7)) '< 0', nbvalm
 220       endif
 221       if ( option.eq.1 .or. option.eq.2 ) then
 222       write (ulsort,texte(langue,7)) '> 0', nbvalp
 223       endif
 224       iaux = min(nborig,10)
 225       write (ulsort,texte(langue,6)) 'filtre ', 1, iaux,
 226      >            (tbaux1(jaux),jaux=1,iaux)
 227       if ( nborig.gt.10 ) then
 228         write (ulsort,texte(langue,6)) 'filtre ',
 229      >               nborig-iaux+1, nborig,
 230      >              (tbaux1(iaux),iaux=nborig-iaux+1,nborig)
 231       endif
 232 #endif
 233 c
 234 c====
 235 c 3. tri du tableau epure
 236 c====
 237 c
 238       if ( codret.eq.0 ) then
 239 c
 240 #ifdef _DEBUG_HOMARD_
 241       write (ulsort,texte(langue,3)) 'UTTRII', nompro
 242 #endif
 243       call uttrii ( classt, vmin, vmax,
 244      >              nborig, tbaux1,
 245      >              ulsort, langue, codret)
 246 c
 247 #ifdef _DEBUG_HOMARD_
 248       write (ulsort,texte(langue,8)) 'mini', vmin
 249       write (ulsort,texte(langue,8)) 'maxi', vmax
 250       iaux = min(nborig,10)
 251       write (ulsort,texte(langue,6)) 'classt ', 1, iaux,
 252      >            (classt(jaux),jaux=1,iaux)
 253       if ( nborig.gt.10 ) then
 254         write (ulsort,texte(langue,6)) 'classt ', nborig-iaux+1,nborig,
 255      >              (classt(jaux),jaux=nborig-iaux+1,nborig)
 256       endif
 257 #endif
 258 c
 259       endif
 260 c
 261 c====
 262 c 4. rangement final
 263 c====
 264 c
 265       if ( codret.eq.0 ) then
 266 c
 267       do 40 , iaux = 1 , nborig
 268         tbconv(iaux) = 0
 269    40 continue
 270 c
 271       do 41 , iaux = 1 , nbvalm
 272         tbconv(classt(iaux)) = iaux
 273    41 continue
 274 c
 275       jaux = nborig - nbvalp + 1
 276       kaux = nbvalm + 1 - jaux
 277       do 42 , iaux = jaux , nborig
 278         tbconv(classt(iaux)) = iaux + kaux
 279    42 continue
 280 c
 281 #ifdef _DEBUG_HOMARD_
 282       iaux = min(nborig,10)
 283       write (ulsort,texte(langue,6)) 'tbconv ', 1, iaux,
 284      >            (tbconv(jaux),jaux=1,iaux)
 285       if ( nborig.gt.10 ) then
 286         write (ulsort,texte(langue,6)) 'tbconv ', nborig-iaux+1,nborig,
 287      >              (tbconv(jaux),jaux=nborig-iaux+1,nborig)
 288       endif
 289 #endif
 290 c
 291       endif
 292 c
 293 c====
 294 c 5. la fin
 295 c====
 296 c
 297       if ( codret.ne.0 ) then
 298 c
 299 #include "envex2.h"
 300 c
 301       write (ulsort,texte(langue,1)) 'Sortie', nompro
 302       write (ulsort,texte(langue,2)) codret
 303       write (ulsort,texte(langue,5)) option
 304 c
 305       endif
 306 c
 307 #ifdef _DEBUG_HOMARD_
 308       write (ulsort,texte(langue,1)) 'Sortie', nompro
 309       call dmflsh (iaux)
 310 #endif
 311 c
 312       end