src/tool/Utilitaire/utchs8.F

   1       subroutine utchs8 ( chacar, lgchac, tabch8,
   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 - transfere une CHaine dans un tableau de String*8
  24 c   --                         --                        -      -
  25 c
  26 c   Remarque : on transfere stricto sensu le nombre de caracteres
  27 c              demandes, sans se preoccuper de savoir s'il y a des
  28 c              blancs ou des "mauvais" caracteres.
  29 c   Remarque : si on est oblige d'entamer une nouvelle case du tableau,
  30 c              on complete a droite par des blancs.
  31 c
  32 c   Exemple :
  33 c
  34 c   chacar = 'Sous le pont Mirabeau coule la Seine'
  35 c             123456789012345678901234567890123456
  36 c   lgchac = 36
  37 c                           12345678
  38 c   devient : tabch8 (1) = 'Sous le '
  39 c             tabch8 (2) = 'pont Mir'
  40 c             tabch8 (3) = 'abeau co'
  41 c             tabch8 (4) = 'ule la S'
  42 c             tabch8 (5) = 'eine    '
  43 c ______________________________________________________________________
  44 c .        .     .        .                                            .
  45 c .  nom   . e/s . taille .           description                      .
  46 c .____________________________________________________________________.
  47 c . chacar . e   .char*(*). chaine de caractere                        .
  48 c . lgchac . e   .    1   . nombre de caracteres a transferer          .
  49 c . tabch8 .   s .   *    . tableau a remplir                          .
  50 c . ulsort . e   .   1    . unite logique de la sortie generale        .
  51 c . langue . e   .    1   . langue des messages                        .
  52 c .        .     .        . 1 : francais, 2 : anglais                  .
  53 c . codret .  s  .    1   . code de retour des modules                 .
  54 c .        .     .        . 0 : pas de probleme                        .
  55 c .        .     .        . 1 : chaine trop courte                     .
  56 c ______________________________________________________________________
  57 c
  58 c====
  59 c 0. declarations et dimensionnement
  60 c====
  61 c
  62 c 0.1. ==> generalites
  63 c
  64       implicit none
  65       save
  66 c
  67       character*6 nompro
  68       parameter ( nompro = 'UTCHS8' )
  69 c
  70 #include "nblang.h"
  71 c
  72 c 0.2. ==> communs
  73 c
  74 #include "envex1.h"
  75 c
  76 c 0.3. ==> arguments
  77 c
  78       integer lgchac
  79 c
  80       character*8 tabch8(*)
  81       character*(*) chacar
  82 c
  83       integer ulsort, langue, codret
  84 c
  85       integer nbmess
  86       parameter (nbmess = 10 )
  87       character*80 texte(nblang,nbmess)
  88 c
  89 c 0.4. ==> variables locales
  90 c
  91       integer iaux, jaux
  92       integer lencha, nbchar, nbpack
  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) = '(''Chaine a transferer : '')'
 109       texte(1,5) = '(''La chaine est declaree en char*'',i4)'
 110       texte(1,6) = '(''mais on veut transferer '',i4,'' caracteres !'')'
 111 c
 112       texte(2,4) = '(''String to convert : '')'
 113       texte(2,5) = '(''The string is declared as char*'',i4)'
 114       texte(2,6) = '(''but, '',i4,'' characters must be moved !'')'
 115 c
 116 #ifdef _DEBUG_HOMARD_
 117       write (ulsort,texte(langue,4))
 118       write (ulsort,*) chacar
 119 #endif
 120 c
 121 c====
 122 c 2. verification de la longueur
 123 c====
 124 c
 125       codret = 0
 126 c
 127       lencha = len(chacar)
 128       if ( lgchac.gt.lencha ) then
 129         codret = 1
 130       endif
 131 c
 132 c====
 133 c 3. transfert
 134 c====
 135 c
 136       if ( codret.eq.0 ) then
 137 c
 138       nbchar = mod(lgchac,8)
 139       nbpack = ( lgchac - nbchar ) / 8
 140 c
 141       jaux = 1
 142       do 31 , iaux = 1 , nbpack
 143         tabch8(iaux) = chacar(jaux:jaux+7)
 144         jaux = jaux + 8
 145    31 continue
 146 c
 147       if ( nbchar.gt.0 ) then
 148 c                           12345678
 149         tabch8(nbpack+1) = '        '
 150         tabch8(nbpack+1)(1:nbchar) = chacar(jaux:jaux+nbchar-1)
 151       endif
 152 c
 153       endif
 154 c
 155 c====
 156 c 3. la fin
 157 c====
 158 c
 159       if ( codret.ne.0 ) then
 160 c
 161 #include "envex2.h"
 162         write (ulsort,texte(langue,1)) 'Sortie', nompro
 163         write (ulsort,texte(langue,2)) codret
 164         write (ulsort,texte(langue,4))
 165         write (ulsort,*) chacar
 166         write (ulsort,texte(langue,5)) lencha
 167         write (ulsort,texte(langue,6)) lgchac
 168       endif
 169 c
 170 #ifdef _DEBUG_HOMARD_
 171       write (ulsort,texte(langue,1)) 'Sortie', nompro
 172       call dmflsh (iaux)
 173 #endif
 174 c
 175       end