src/tool/Utilitaire/utcte3.F

   1       subroutine utcte3 ( option, nborig, tborig,
   2      >                    nbconv, tbconv,
   3      >                    ulsort, langue, codret )
   4 c ______________________________________________________________________
   5 c
   6 c                             H O M A R D
   7 c
   8 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   9 c
  10 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  11 c aupres des huissiers de justice Simart et Lavoir a Clamart
  12 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  13 c aupres des huissiers de justice
  14 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  15 c
  16 c    HOMARD est une marque deposee d'Electricite de France
  17 c
  18 c Copyright EDF 1996
  19 c Copyright EDF 1998
  20 c Copyright EDF 2002
  21 c Copyright EDF 2020
  22 c ______________________________________________________________________
  23 c
  24 c    UTilitaire - Conversion de Tableau Entier - action 3
  25 c    --           -             -       -               -
  26 c
  27 c   On retourne un tableau entier qui contient :
  28 c   . soit 0 si le critere n'est pas satisfait,
  29 c   . soit le rang correspondant si le critere est satisfait
  30 c    . si abs(option) = 1 : on retient les valeurs non nulles
  31 c    . si abs(option) = 2 : on retient les valeurs strictement positives
  32 c    . si abs(option) = 3 : on retient les valeurs strictement negatives
  33 c    . si option > 0 : ce rang est celui dans le tableau initial
  34 c    . si option < 0 : ce rang est le numero d'apparition de la valeur
  35 c
  36 c Exemples : tableau d'origine : (  0, 13,  0, -1,  4, -3,  0,  1 )
  37 c
  38 c  option  1 : filtre les valeurs non nulles, selon le rangement initial
  39 c            tableau converti  : (  2,  4,  5,  6,  8,  0,  0,  0)
  40 c  option -1 : filtre les valeurs non nulles, selon l'ordre d'apparition
  41 c            tableau converti  : (  0,  1,  0,  2,  3,  4,  0,  5)
  42 c  option  2 : filtre les valeurs > 0, selon le rangement initial
  43 c            tableau converti  : (  2,  5,  8,  0,  0,  0,  0,  0)
  44 c  option -2 : filtre les valeurs > 0, selon l'ordre d'apparition
  45 c            tableau converti  : (  0,  1,  0,  0,  2,  0,  0,  3)
  46 c  option  3 : filtre les valeurs < 0, selon le rangement initial
  47 c            tableau converti  : (  4,  6,  0,  0,  0,  0,  0,  0)
  48 c  option -3 : filtre les valeurs < 0, selon l'ordre d'apparition
  49 c            tableau converti  : (  0,  0,  0,  1,  0,  2,  0,  0)
  50 c
  51 c remarque : l'action elle-meme est faite ici
  52 c            on peut enrober ce traitement par utcte1, pour gerer
  53 c            des allocations de tableau
  54 c ______________________________________________________________________
  55 c .        .     .        .                                            .
  56 c .  nom   . e/s . taille .           description                      .
  57 c .____________________________________________________________________.
  58 c . option . e   .    1   . option de la conversion                    .
  59 c .        .     .        . abs(option) = 1 : les valeurs non nulles   .
  60 c .        .     .        . abs(option) = 2 : les valeurs > 0          .
  61 c .        .     .        . abs(option) = 3 : les valeurs < 0          .
  62 c .        .     .        . option > 0 : rang dans le tableau initial  .
  63 c .        .     .        . option < 0 : numero d'apparition           .
  64 c . nborig . e   .    1   . nombre de valeurs dasn le tableau original .
  65 c . tborig . e   . nborig . tableau original a convertir               .
  66 c . tbconv .   s . nborig . tableau converti                           .
  67 c . nbconv .   s .   1    . nombre de valeurs filtrees                 .
  68 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  69 c . langue . e   .    1   . langue des messages                        .
  70 c .        .     .        . 1 : francais, 2 : anglais                  .
  71 c . codret . es  .    1   . code de retour des modules                 .
  72 c .        .     .        . 0 : pas de probleme                        .
  73 c .        .     .        . -1 : mauvaise demande pour le type de nom  .
  74 c .        .     .        . -2 : mauvaise demande pour l'option        .
  75 c .        .     .        . -3 : probleme sur le tableau a convertir   .
  76 c .        .     .        . autre : probleme dans l'allocation         .
  77 c ______________________________________________________________________
  78 c
  79 c====
  80 c 0. declarations et dimensionnement
  81 c====
  82 c
  83 c 0.1. ==> generalites
  84 c
  85       implicit none
  86       save
  87 c
  88       character*6 nompro
  89       parameter ( nompro = 'UTCTE3' )
  90 c
  91 #include "nblang.h"
  92 c
  93 c 0.2. ==> communs
  94 c
  95 #include "envex1.h"
  96 c
  97 c 0.3. ==> arguments
  98 c
  99       integer option
 100       integer nborig, nbconv
 101       integer tborig(nborig), tbconv(nborig)
 102 c
 103       integer ulsort, langue, codret
 104 c
 105 c 0.4. ==> variables locales
 106 c
 107       integer iaux
 108 #ifdef _DEBUG_HOMARD_
 109       integer jaux
 110 #endif
 111 c
 112       integer nbmess
 113       parameter ( nbmess = 10 )
 114       character*80 texte(nblang,nbmess)
 115 c
 116 c 0.5. ==> initialisations
 117 c ______________________________________________________________________
 118 c
 119 c====
 120 c 1. messages
 121 c====
 122 c
 123 #include "impr01.h"
 124 c
 125 #ifdef _DEBUG_HOMARD_
 126       write (ulsort,texte(langue,1)) 'Entree', nompro
 127       call dmflsh (iaux)
 128 #endif
 129 c
 130       texte(1,4) = '(''Option :'',i4)'
 131       texte(1,5) = '(''Mauvaise demande d''''option :'',i8)'
 132       texte(1,6) = '(''Tableau '',a,'', de'',i8,'' a'',i8,'' : '',10i8)'
 133       texte(1,7) = '(''Nombre de valeurs filtrees : '',i8)'
 134 c
 135       texte(2,4) = '(''Option :'',i4)'
 136       texte(2,5) = '(''Bad request for the option :'',i8)'
 137       texte(2,6) = '(a,'' array, '',a,'' : '',10i8)'
 138       texte(2,7) = '(''Number of filtered values : '',i8)'
 139 c
 140 #ifdef _DEBUG_HOMARD_
 141       write (ulsort,texte(langue,4)) option
 142 #endif
 143 c
 144       codret = 0
 145 c
 146 c====
 147 c 2. conversion
 148 c====
 149 c
 150 #ifdef _DEBUG_HOMARD_
 151       iaux = min(nborig,10)
 152       write (ulsort,texte(langue,6)) 'initial', 1, iaux,
 153      >            (tborig(jaux),jaux=1,iaux)
 154       if ( nborig.gt.10 ) then
 155         write (ulsort,texte(langue,6)) 'initial', nborig-iaux+2,nborig,
 156      >              (tborig(iaux),iaux=nborig-iaux+2,nborig)
 157       endif
 158 #endif
 159 c
 160       nbconv = 0
 161 c
 162 c 2.0. ==> mise a zero par defaut
 163 c
 164       do 20 , iaux = 1 , nborig
 165         tbconv(iaux) = 0
 166    20 continue
 167 c
 168 c 2.1. ==> on considere toutes les valeurs non nulles
 169 c
 170       if ( abs(option).eq.1 ) then
 171 c
 172         do 21 , iaux = 1 , nborig
 173 c
 174           if ( tborig(iaux).ne.0 ) then
 175             nbconv = nbconv + 1
 176             if ( option.gt.0 ) then
 177               tbconv(nbconv) = iaux
 178             else
 179               tbconv(iaux) = nbconv
 180             endif
 181           endif
 182 c
 183    21   continue
 184 c
 185 c 2.2. ==> on considere toutes les valeurs non nulles et positives
 186 c
 187       elseif ( abs(option).eq.2 ) then
 188 c
 189         do 22 , iaux = 1 , nborig
 190 c
 191           if ( tborig(iaux).gt.0 ) then
 192             nbconv = nbconv + 1
 193             if ( option.gt.0 ) then
 194               tbconv(nbconv) = iaux
 195             else
 196               tbconv(iaux) = nbconv
 197             endif
 198           endif
 199 c
 200    22   continue
 201 c
 202 c 2.3. ==> on considere toutes les valeurs non nulles et positives
 203 c
 204       elseif ( abs(option).eq.3 ) then
 205 c
 206         do 23 , iaux = 1 , nborig
 207 c
 208           if ( tborig(iaux).lt.0 ) then
 209             nbconv = nbconv + 1
 210             if ( option.gt.0 ) then
 211               tbconv(nbconv) = iaux
 212             else
 213               tbconv(iaux) = nbconv
 214             endif
 215           endif
 216 c
 217    23   continue
 218 c
 219 c 2.4. ==> erreur
 220 c
 221       else
 222 c
 223         codret = -2
 224 c
 225       endif
 226 c
 227 #ifdef _DEBUG_HOMARD_
 228       write (ulsort,texte(langue,7)) nbconv
 229       iaux = min(nborig,10)
 230       write (ulsort,texte(langue,6)) 'final  ', 1, iaux,
 231      >            (tbconv(jaux),jaux=1,iaux)
 232       if ( nborig.gt.10 ) then
 233         write (ulsort,texte(langue,6)) 'final  ', nborig-iaux+2,nborig,
 234      >              (tbconv(iaux),iaux=nborig-iaux+2,nborig)
 235       endif
 236 #endif
 237 c
 238 c====
 239 c 3. la fin
 240 c====
 241 c
 242       if ( codret.ne.0 ) then
 243 c
 244 #include "envex2.h"
 245 c
 246       write (ulsort,texte(langue,1)) 'Sortie', nompro
 247       write (ulsort,texte(langue,2)) codret
 248       write (ulsort,texte(langue,5)) option
 249 c
 250       endif
 251 c
 252 #ifdef _DEBUG_HOMARD_
 253       write (ulsort,texte(langue,1)) 'Sortie', nompro
 254       call dmflsh (iaux)
 255 #endif
 256 c
 257       end