src/tool/Utilitaire/utench.F

   1       subroutine utench ( entier, cadrag, lgchac, chacar,
   2      >                    ulsort, langue, codret )
   3 c ______________________________________________________________________
   4 c
   5 c                             H O M A R D
   6 c
   7 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   8 c
   9 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  10 c aupres des huissiers de justice Simart et Lavoir a Clamart
  11 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  12 c aupres des huissiers de justice
  13 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  14 c
  15 c    HOMARD est une marque deposee d'Electricite de France
  16 c
  17 c Copyright EDF 1996
  18 c Copyright EDF 1998
  19 c Copyright EDF 2002
  20 c Copyright EDF 2020
  21 c ______________________________________________________________________
  22 c
  23 c   UTilitaire - convertit un ENtier en CHaine de caractere
  24 c   --                        --        --
  25 c
  26 c   Si la chaine fournie est plus longue que le nombre de chiffres a
  27 c   ecrire, on complete par des blancs a droite ou a gauche, ou des 0
  28 c   a gauche selon le type de cadrage demande.
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . entier . e   .    1   . entier a convertir                         .
  34 c . cadrag . e   . char*1 . type de cadrage d'entier ecrit             .
  35 c .        .     .        . g/G : le nombre est cadre a gauche : '83  '.
  36 c .        .     .        . d/D : le nombre est cadre a droite : '  83'.
  37 c .        .     .        .       et on complete par des blancs        .
  38 c .        .     .        . 0   : le nombre est cadre a droite et on   .
  39 c .        .     .        .       complete par des 0 : '0083'          .
  40 c .        .     .        . _   : le nombre est cadre a droite et on   .
  41 c .        .     .        .       complete par des _ : '__83'          .
  42 c . lgchac .   s .    1   . longueur de la chaine obtenue              .
  43 c . chacar .   s .char*(*). chaine de caractere                        .
  44 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  45 c . langue . e   .    1   . langue des messages                        .
  46 c .        .     .        . 1 : francais, 2 : anglais                  .
  47 c . codret .  s  .    1   . code de retour des modules                 .
  48 c .        .     .        . 0 : pas de probleme                        .
  49 c .        .     .        . 1 : chaine trop courte                     .
  50 c .        .     .        . 2 : le nombre est trop grand               .
  51 c .        .     .        . 3 : type de cadrage inconnu                .
  52 c ______________________________________________________________________
  53 c
  54 c====
  55 c 0. declarations et dimensionnement
  56 c====
  57 c
  58 c 0.1. ==> generalites
  59 c
  60       implicit none
  61       save
  62 c
  63       character*6 nompro
  64       parameter ( nompro = 'UTENCH' )
  65 c
  66 #include "nblang.h"
  67 c
  68 c 0.2. ==> communs
  69 c
  70 #include "envex1.h"
  71 c
  72 c 0.3. ==> arguments
  73 c
  74       integer entier, lgchac
  75 c
  76       character*1 cadrag
  77       character*(*) chacar
  78 c
  79       integer ulsort, langue, codret
  80 c
  81       integer nbmess
  82       parameter (nbmess = 20 )
  83       character*80 texte(nblang,nbmess)
  84 c
  85 c 0.4. ==> variables locales
  86 c
  87       integer iaux, jaux, kaux, lgch00
  88 c
  89       logical cadgau, negati
  90 c
  91       character*1 saux01
  92       character*5 fmt
  93 c
  94 c 0.5. ==> initialisations
  95 c ______________________________________________________________________
  96 c
  97 c====
  98 c 1. messages
  99 c====
 100 c
 101 #include "impr01.h"
 102 c
 103 #ifdef _DEBUG_HOMARD_
 104       write (ulsort,texte(langue,1)) 'Entree', nompro
 105       call dmflsh (iaux)
 106 #endif
 107 c
 108       texte(1,4) = '(''Cadrage voulu      : '',a1)'
 109       texte(1,5) = '(''La chaine est trop petite : longueur = '',i4)'
 110       texte(1,6) = '(''Il faudrait au moins '',i4,'' places.'')'
 111       texte(1,7) = '(''Le nombre est trop grand.'')'
 112       texte(1,8) = '(''Le type de cadrage est mauvais : '',a1)'
 113       texte(1,9) = '(''Longueur de la chaine obtenue : '',i8)'
 114       texte(1,10) = '(''Chaine obtenue : '',a,/)'
 115       texte(1,20) = '(''Entier a convertir : '',i8)'
 116 c
 117       texte(2,4) = '(''Choice             : '',a1)'
 118       texte(2,5) = '(''The string is too short : length = '',i4)'
 119       texte(2,6) = '(''At less'',i4,'' places are needed.'')'
 120       texte(2,7) = '(''The integer is too big.'')'
 121       texte(2,8) = '(''Bad choice : '',a1)'
 122       texte(2,9) = '(''Lenght of chain : '',i8)'
 123       texte(2,10) = '(''Chain : '',a,/)'
 124       texte(2,20) = '(''Integer to convert : '',i8)'
 125 c
 126 #ifdef _DEBUG_HOMARD_
 127       write (ulsort,texte(langue,20)) entier
 128       write (ulsort,texte(langue,4)) cadrag
 129 #endif
 130 c
 131 c====
 132 c 2. decodage
 133 c====
 134 c
 135       codret = 0
 136 c
 137 c 2.1. ==> type de cadrage
 138 c
 139       if ( cadrag.eq.'d' .or. cadrag.eq.'D' .or.
 140      >     cadrag.eq.'0' .or. cadrag.eq.'_' ) then
 141         cadgau = .false.
 142       elseif ( cadrag.eq.'g' .or. cadrag.eq.'G' ) then
 143         cadgau = .true.
 144       else
 145         codret = 3
 146       endif
 147 c
 148 c 2.2. ==> point de depart
 149 c
 150       lgch00 = len(chacar)
 151       kaux = entier
 152 c
 153 c 2.3. ==> si le numero est strictement negatif, il faut inserer -
 154 c
 155       if ( codret.eq.0 ) then
 156 c
 157       if ( kaux.lt.0 ) then
 158         lgchac = 1
 159         if ( lgch00.le.1 ) then
 160           codret = 1
 161         endif
 162         if ( codret.eq.0 ) then
 163           negati = .true.
 164           kaux = - kaux
 165         endif
 166       else
 167         lgchac = 0
 168         negati = .false.
 169       endif
 170 c
 171       endif
 172 c
 173 c 2.4. ==> nombre de chiffres de l'entier a convertir et ecriture
 174 c
 175       if ( codret.eq.0 ) then
 176 c
 177 c 2.4.1. ==> si le numero est nul : on le traite tout de suite car cela
 178 c            simplifie l'algorithme general
 179 c
 180       if ( kaux.eq.0 ) then
 181 c
 182         if ( lgch00.eq.0 ) then
 183           codret = 1
 184         endif
 185         if ( codret.eq.0 ) then
 186           if ( cadgau ) then
 187             chacar(1:1) = '0'
 188           else
 189             chacar(lgch00:lgch00) = '0'
 190           endif
 191           lgchac = 1
 192         endif
 193 c
 194 c 2.4.2. ==> pour un nombre non nul, le puissance de 10 immediatement
 195 c            superieure equivaut au nombre de chiffres.
 196 c
 197       else
 198 c
 199         jaux = 0
 200         do 2421 , iaux = 1 , 99
 201           if ( kaux.lt.10**iaux ) then
 202             jaux = iaux
 203             goto 2422
 204           endif
 205  2421   continue
 206 c
 207  2422   continue
 208 c
 209         if ( jaux.eq.0 ) then
 210           codret = 2
 211         elseif ( lgchac+jaux.gt.lgch00 ) then
 212           codret = 1
 213           lgchac = lgchac+jaux
 214         else
 215           fmt = '(I   '
 216           if ( jaux.lt.10 ) then
 217             write(fmt(3:3),'(i1)') jaux
 218             fmt(4:4) = ')'
 219           else
 220             write(fmt(3:4),'(i2)') jaux
 221             fmt(5:5) = ')'
 222           endif
 223           if ( cadgau ) then
 224             write (chacar(lgchac+1:lgchac+jaux),fmt) kaux
 225             if ( negati ) then
 226               chacar(lgchac:lgchac) = '-'
 227             endif
 228           else
 229             write (chacar(lgch00-jaux+1:lgch00),fmt) kaux
 230             if ( negati ) then
 231               chacar(lgch00-jaux:lgch00-jaux) = '-'
 232             endif
 233           endif
 234           lgchac = lgchac+jaux
 235         endif
 236 c
 237       endif
 238 c
 239       endif
 240 c
 241 c 2.5. ==> complement avec des blancs ou des zeros
 242 c
 243       if ( codret.eq.0 ) then
 244 c
 245       if ( cadgau ) then
 246         saux01 = ' '
 247         jaux = lgchac+1
 248         kaux = lgch00
 249       else
 250         if ( cadrag.eq.'0' ) then
 251           saux01 = '0'
 252         elseif ( cadrag.eq.'_' ) then
 253           saux01 = '_'
 254         else
 255           saux01 = ' '
 256         endif
 257         jaux = 1
 258         kaux = lgch00-lgchac
 259         lgchac = lgch00
 260       endif
 261 c
 262       do 25 , iaux = jaux, kaux
 263         chacar(iaux:iaux) = saux01
 264    25 continue
 265 c
 266 #ifdef _DEBUG_HOMARD_
 267       write (ulsort,texte(langue,9)) lgchac
 268       write (ulsort,texte(langue,10)) chacar
 269 #endif
 270 c
 271       endif
 272 c
 273 c====
 274 c 3. la fin
 275 c====
 276 c
 277       if ( codret.ne.0 ) then
 278 c
 279 #include "envex2.h"
 280 c
 281       write (ulsort,texte(langue,1)) 'Sortie', nompro
 282       write (ulsort,texte(langue,2)) codret
 283       write (ulsort,texte(langue,20)) entier
 284       if ( codret.eq.1 ) then
 285         write (ulsort,texte(langue,5)) lgch00
 286         write (ulsort,texte(langue,6)) lgchac
 287       elseif ( codret.eq.2 ) then
 288         write (ulsort,texte(langue,7))
 289       elseif ( codret.eq.3 ) then
 290         write (ulsort,texte(langue,8)) cadrag
 291       endif
 292 c
 293 #ifdef _DEBUG_HOMARD_
 294       write (ulsort,texte(langue,1)) 'Sortie', nompro
 295       call dmflsh (iaux)
 296 #endif
 297 c
 298       endif
 299 c
 300       end