src/tool/Utilitaire/utcte2.F

   1       subroutine utcte2 ( ntorig, typnom, option,
   2      >                    ntconv, adconv,
   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 2
  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 option = 1 : on retient les valeurs non nulles
  31 c    . si option = 2 : on retient les valeurs strictement positives
  32 c    . si option = 3 : on retient les valeurs strictement negatives
  33 c
  34 c Exemples : tableau d'origine : (  0, 13,  0, -1,  4, -3,  0,  1 )
  35 c
  36 c  option  1 : ordonne les valeurs non nulles
  37 c            tableau converti  : (  0,  5,  0,  2,  4,  1,  0,  3)
  38 c  option  2 : ordonne les valeurs > 0
  39 c            tableau converti  : (  0,  3,  0,  0,  2,  0,  0,  1)
  40 c  option  3 : ordonne les valeurs < 0
  41 c            tableau converti  : (  0,  0,  0,  2,  0,  1,  0,  0)
  42 c
  43 c remarque : l'action elle-meme est faite dans utcte4
  44 c            ici, on traite les allocations de tableau
  45 c ______________________________________________________________________
  46 c .        .     .        .                                            .
  47 c .  nom   . e/s . taille .           description                      .
  48 c .____________________________________________________________________.
  49 c . ntorig . e   .   *    . objet contenant le tableau a convertir     .
  50 c . typnom . e   .    1   . 0 : le nom du tableau converti est a creer .
  51 c .        .     .        .     automatiquement                        .
  52 c .        .     .        . 1 : le nom est impose a l'appel            .
  53 c . option . e   .    1   . option de la conversion                    .
  54 c .        .     .        . option = 1 : les valeurs non nulles        .
  55 c .        .     .        . option = 2 : les valeurs > 0               .
  56 c .        .     .        . option = 3 : les valeurs < 0               .
  57 c . ntconv . es  .   *    . objet contenant le tableau converti        .
  58 c . adconv .   s .   1    . adresse du tableau converti                .
  59 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  60 c . langue . e   .    1   . langue des messages                        .
  61 c .        .     .        . 1 : francais, 2 : anglais                  .
  62 c . codret . es  .    1   . code de retour des modules                 .
  63 c .        .     .        . 0 : pas de probleme                        .
  64 c .        .     .        . -1 : mauvaise demande pour le type de nom  .
  65 c .        .     .        . -2 : mauvaise demande pour l'option        .
  66 c .        .     .        . -3 : probleme sur le tableau a convertir   .
  67 c .        .     .        . autre : probleme dans l'allocation         .
  68 c ______________________________________________________________________
  69 c
  70 c====
  71 c 0. declarations et dimensionnement
  72 c====
  73 c
  74 c 0.1. ==> generalites
  75 c
  76       implicit none
  77       save
  78 c
  79       character*6 nompro
  80       parameter ( nompro = 'UTCTE2' )
  81 c
  82 #include "nblang.h"
  83 c
  84 c 0.2. ==> communs
  85 c
  86 #include "envex1.h"
  87 c
  88 #include "gmenti.h"
  89 c
  90 c 0.3. ==> arguments
  91 c
  92       character*(*) ntorig, ntconv
  93 c
  94       integer typnom, option
  95       integer adconv
  96 c
  97       integer ulsort, langue, codret
  98 c
  99 c 0.4. ==> variables locales
 100 c
 101       integer codre1, codre2
 102       integer codre0
 103       integer iaux
 104       integer adtra1, adtra2
 105       integer adorig, nborig
 106 c
 107       character*8 ntrav1, ntrav2
 108 c
 109       integer nbmess
 110       parameter ( nbmess = 10 )
 111       character*80 texte(nblang,nbmess)
 112 c
 113 c 0.5. ==> initialisations
 114 c ______________________________________________________________________
 115 c
 116 c====
 117 c 1. messages
 118 c====
 119 c
 120 #include "impr01.h"
 121 c
 122 #ifdef _DEBUG_HOMARD_
 123       write (ulsort,texte(langue,1)) 'Entree', nompro
 124       call dmflsh (iaux)
 125 #endif
 126 c
 127       texte(1,10) = '(''Conversion du tableau entier : '',a)'
 128       texte(1,4) = '(''Option :'',i4)'
 129       texte(1,5) = '(''Mauvaise demande de type de nom :'',i8)'
 130       texte(1,6) = '(''Mauvaise demande d''''option :'',i8)'
 131       texte(1,7) = '(''Probleme sur le tableau original.'')'
 132       texte(1,8) = '(''Probleme pour allouer le tableau converti.'')'
 133 c
 134       texte(2,10) = '(''Conversion of integer array : '',a)'
 135       texte(2,4) = '(''Option :'',i4)'
 136       texte(2,5) = '(''Bad request for the name :'',i8)'
 137       texte(2,6) = '(''Bad request for the option :'',i8)'
 138       texte(2,7) = '(''Problem with the origin array.'')'
 139       texte(2,8) = '(''Problem while allocating object '')'
 140 c
 141 #ifdef _DEBUG_HOMARD_
 142       write (ulsort,texte(langue,10)) ntorig
 143       write (ulsort,texte(langue,4)) option
 144 #endif
 145 c
 146 c====
 147 c 2. prealables
 148 c====
 149 c
 150 c 2.1. ==> caracteristiques du tableau a convertir
 151 c
 152       call gmadoj ( ntorig, adorig, nborig, codret )
 153 c
 154       if ( codret.ne.0 ) then
 155         codret = -3
 156       endif
 157 c
 158 c 2.2. ==> allocation du tableau converti
 159 c
 160       if ( codret.eq.0 ) then
 161 c
 162       if ( typnom.eq.0 ) then
 163 c
 164         call gmalot ( ntconv, 'entier  ', nborig, adconv, codret )
 165         codret = abs(codret)
 166 c
 167       elseif ( typnom.eq.1 ) then
 168 c
 169         call gmaloj ( ntconv, 'entier  ', nborig, adconv, codret )
 170         codret = abs(codret)
 171 c
 172       else
 173 c
 174         codret = -1
 175 c
 176       endif
 177 c
 178       endif
 179 c
 180 c 2.3. ==> tableaux de travail
 181 c
 182       if ( codret.eq.0 ) then
 183 c
 184       call gmalot ( ntrav1, 'entier  ', nborig, adtra1, codre1 )
 185       call gmalot ( ntrav2, 'entier  ', nborig, adtra2, codre2 )
 186 c
 187       codre0 = min ( codre1, codre2 )
 188       codret = max ( abs(codre0), codret,
 189      >               codre1, codre2 )
 190 c
 191       endif
 192 c
 193 c====
 194 c 3. conversion
 195 c====
 196 c
 197       if ( codret.eq.0 ) then
 198 c
 199 #ifdef _DEBUG_HOMARD_
 200       iaux = min(nborig,25)
 201       call gmprot (nompro, ntorig, 1, iaux )
 202       if ( nborig.gt.25 ) then
 203         call gmprot (nompro, ntorig, nborig-24, nborig )
 204       endif
 205 #endif
 206 c
 207       iaux = nborig
 208 #ifdef _DEBUG_HOMARD_
 209       write (ulsort,texte(langue,3)) 'UTCTE4', nompro
 210 #endif
 211       call utcte4 ( option, iaux, imem(adorig),
 212      >              imem(adconv),
 213      >              imem(adtra1), imem(adtra2),
 214      >              ulsort, langue, codret )
 215 c
 216 #ifdef _DEBUG_HOMARD_
 217       iaux = min(nborig,25)
 218       call gmprot (nompro, ntconv, 1, iaux )
 219       if ( nborig.gt.25 ) then
 220         call gmprot (nompro, ntconv, nborig-24, nborig )
 221       endif
 222 #endif
 223 c
 224       endif
 225 c
 226 c====
 227 c 4. menage
 228 c====
 229 c
 230       if ( codret.eq.0 ) then
 231 c
 232       call gmlboj ( ntrav1, codre1 )
 233       call gmlboj ( ntrav2, codre2 )
 234 c
 235       codre0 = min ( codre1, codre2 )
 236       codret = max ( abs(codre0), codret,
 237      >               codre1, codre2 )
 238 c
 239       endif
 240 c
 241 c====
 242 c 5. la fin
 243 c====
 244 c
 245       if ( codret.ne.0 ) then
 246 c
 247 #include "envex2.h"
 248 c
 249       write (ulsort,texte(langue,1)) 'Sortie', nompro
 250       write (ulsort,texte(langue,2)) codret
 251       write (ulsort,texte(langue,10)) ntorig
 252       if ( codret.eq.-1 ) then
 253         write (ulsort,texte(langue,5)) typnom
 254       elseif ( codret.eq.-2 ) then
 255         write (ulsort,texte(langue,6)) option
 256       elseif ( codret.eq.-3 ) then
 257         write (ulsort,texte(langue,7))
 258       else
 259         write (ulsort,texte(langue,8))
 260       endif
 261 c
 262 #ifdef _DEBUG_HOMARD_
 263       write (ulsort,texte(langue,1)) 'Sortie', nompro
 264       call dmflsh (iaux)
 265 #endif
 266 c
 267       endif
 268 c
 269       end