src/tool/Gestion_MTU/gmprot.F

   1       subroutine gmprot ( chaine, nom, ideb, ifin )
   2 c ______________________________________________________________________
   3 c
   4 c                             H O M A R D
   5 c
   6 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   7 c
   8 c Version originale enregistree le 18 juin 1996 sous le numero 96036
   9 c aupres des huissiers de justice Simart et Lavoir a Clamart
  10 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  11 c aupres des huissiers de justice
  12 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  13 c
  14 c    HOMARD est une marque deposee d'Electricite de France
  15 c
  16 c Copyright EDF 1996
  17 c Copyright EDF 1998
  18 c Copyright EDF 2002
  19 c Copyright EDF 2020
  20 c ______________________________________________________________________
  21 c
  22 c but : imprime le contenu de l'objet terminal de nom "nom"
  23 c       entre les indices locaux ideb et ifin compris
  24 c       si les deux indices sont nuls, on imprime tout
  25 c ______________________________________________________________________
  26 c .        .     .        .                                            .
  27 c .  nom   . e/s . taille .           description                      .
  28 c .____________________________________________________________________.
  29 c . chaine . e   . char*  . chaine de commentaire a imprimer           .
  30 c .  nom   . e   . char*  . nom de la structure a imprimer             .
  31 c .  ideb  . e   .   1    . indice local de debut d'impression         .
  32 c .  ifin  . e   .   1    . indice local de fin d'impression           .
  33 c ______________________________________________________________________
  34 c
  35 c====
  36 c 0. declarations et dimensionnement
  37 c====
  38 c
  39 c 0.1. ==> generalites
  40 c
  41       implicit none
  42       save
  43 c
  44       character*6 nompro
  45       parameter ( nompro = 'GMPROT' )
  46 c
  47 #include "genbla.h"
  48 c
  49 #include "gmmatc.h"
  50 c
  51 c 0.2. ==> communs
  52 c
  53 #include "gmenti.h"
  54 #include "gmreel.h"
  55 #include "gmstri.h"
  56 c
  57 #include "gmtail.h"
  58 c
  59 #include "gmcoer.h"
  60 #include "gmimpr.h"
  61 #include "gmlang.h"
  62 c
  63 c 0.3. ==> arguments
  64 c
  65       character*(*) chaine
  66       character*(*) nom
  67 c
  68       integer ideb, ifin
  69 c
  70 c 0.4. ==> variables locales
  71 c
  72       character*2 saux02
  73       character*8 typtab
  74       character*8 nomter
  75       character*45 fmtstr
  76       character*45 fmtent
  77       character*45 fmt131, fmt132
  78       character*45 fmt141, fmt142
  79       character*45 fmt151, fmt152
  80       character*80 saux80
  81 c
  82       integer iaux, jaux
  83       integer lgent
  84       integer iadr, codret, lgtabl, entmax, entmin
  85       integer ledebu, lafin, nrotab
  86 c
  87       logical partie
  88 c
  89       integer nbmess
  90       parameter ( nbmess = 20 )
  91       character*80 texte(nblang,nbmess)
  92 c
  93 c 0.5. ==> initialisations
  94 c ______________________________________________________________________
  95 c
  96 c====
  97 c 1.  messages
  98 c====
  99 c
 100 #include "impr01.h"
 101 c
 102 #ifdef _DEBUG_HOMARD_
 103       write (ulsort,texte(langue,1)) 'Entree', nompro
 104       call dmflsh (iaux)
 105 #endif
 106 c
 107       texte(1,4) = '(''Cet objet est de longueur '',i10,/)'
 108       texte(1,5) = '(''Objet '',a8,'' :'',/,16(''=''))'
 109       texte(1,8) = '(''Impression demandee entre'',i10,'' et'',i10)'
 110       texte(1,9) =
 111      >'(''=== Structure '',a8,'', type '',a8,'' ==='')'
 112       texte(1,10) =
 113      >'(''=== Structure '',a8,'' / '',a,'', type '',a8,'' ==='')'
 114       texte(1,15) =
 115      > '(''Impression partielle entre les indices '',i10,'' et '',i10)'
 116       texte(1,16) = '(''Cet objet est introuvable.'',/)'
 117       texte(1,17) = '(''Mauvais nom d''''objet.'',/)'
 118       texte(1,18) =
 119      > '(''Cet objet est structure ? ou n''''existe pas ?'')'
 120       texte(1,19) = '(''Cet objet est defini plusieurs fois.'')'
 121       texte(1,20) = '(''Impression impossible entre'',i10,'' et'',i10)'
 122 c
 123       texte(2,4) = '(''The length of this object is '',i10,/)'
 124       texte(2,5) = '(''Object '',a8,'' :'',/,17(''=''))'
 125       texte(2,8) = '(''Output is requested between'',i10,'' et'',i10)'
 126       texte(2,9)  = texte(1,9)
 127       texte(2,10) = texte(1,10)
 128       texte(2,15) =
 129      > '(''Partial impression between indices '',i10,'' et '',i10)'
 130       texte(2,16) = '(''This object is not available.'',/)'
 131       texte(2,17) = '(''Bad object name.'',/)'
 132       texte(2,18) =
 133      > '(''This object is structured ? or is not available ?'')'
 134       texte(2,19) = '(''This object is defined several times.'')'
 135       texte(2,20) =
 136      > '(''Output cannot be done between'',i10,'' et'',i10)'
 137 c
 138  1000 format(a)
 139  1100 format(a,/)
 140 c
 141 c               12345678901234567890123456789012345678901234567890
 142       fmtstr = '( y(ixx,'' : '',a8))                           '
 143       fmtent = '( y(ixx,'' : '',iz ))                          '
 144       fmt131 = '(2(i6 ,'' : ( '', g14.7,'' ; '', g14.7,'' )''))    '
 145       fmt132 = '(2(i6 ,'' : ( '',g23.16,'' ; '',g23.16,'' )''))    '
 146       fmt141 = '(3(i6 ,'' : '', g14.7))                        '
 147       fmt142 = '(3(i6 ,'' : '',g23.16))                        '
 148       fmt151 = '(3(i6 ,'' : '',g23.16))                        '
 149       fmt152 = '(2(i6 ,'' : '',g39.32))                        '
 150 c
 151 #ifdef _DEBUG_HOMARD_
 152       write (ulsort,texte(langue,8)) ideb, ifin
 153 #endif
 154 c
 155 c====
 156 c 2. caracteristiques du tableau
 157 c====
 158 c
 159 c 2.1. ==> recherche du nom terminal de l'objet
 160 c
 161       call gmnomc ( nom, nomter, codret )
 162 c
 163       if ( codret.eq.-3 ) then
 164         codret = -2
 165       elseif ( codret.eq.-1 ) then
 166         codret = -1
 167       else
 168         codret = 0
 169       endif
 170 c
 171 c 2.3. ==> reperage du pointeur
 172 c          le code de retour est non nul si le tableau n'est pas
 173 c          un objet simple alloue
 174 c
 175       if ( codret.eq.0 ) then
 176 c
 177          call gbcara ( nomter, nrotab, iadr, lgtabl, typtab )
 178 c
 179          if ( coergm.eq.0 ) then
 180 c
 181            if ( lgtabl.gt.0 ) then
 182 c
 183               if ( ideb.le.1 .and.
 184      >            ( ifin.eq.0 .or. ifin.ge.lgtabl ) ) then
 185                  ledebu = 1
 186                  lafin = lgtabl
 187                  partie = .false.
 188 c
 189               elseif ( ifin.lt.ideb ) then
 190                  codret = -5
 191 c
 192               elseif ( ideb.gt.lgtabl .or. ifin.lt.1 ) then
 193                  codret = -6
 194 c
 195               else
 196                  ledebu = max(ideb,1)
 197                  lafin = min(ifin,lgtabl)
 198                  partie = .true.
 199 c
 200               endif
 201 c
 202            endif
 203 c
 204          elseif ( coergm.eq.1  ) then
 205             codret = -3
 206 c
 207          else
 208             codret = -4
 209 c
 210          endif
 211 c
 212       endif
 213 c
 214 c====
 215 c 3. impression
 216 c    pour les entiers, on optimise la longueur de l'impression
 217 c    . on cherche la plus grande valeur, entmax.
 218 c     on a l'encadrement 10**(n-1) <= entmax < 10**n, donc on utilisera
 219 c     n chiffres significatifs.
 220 c    . si l'une des valeurs du tableau est negative, il faut ajouter
 221 c    une case pour le signe "-".
 222 c====
 223 c
 224 c 3.1. ==> format des indices
 225 c
 226       if ( codret.eq.0 ) then
 227 c
 228       if ( lgtabl.gt.0 ) then
 229 c
 230         saux02 = '3'
 231         do 31 , iaux = 11 , 0 , -1
 232           if ( lafin.gt.10**iaux ) then
 233             if ( iaux.le.6 ) then
 234               write(saux02(1:1),'(i1)') iaux+3
 235             else
 236               write(saux02(1:2),'(i2)') iaux+3
 237             endif
 238             lgent = iaux+3
 239             goto 311
 240           endif
 241    31   continue
 242 c
 243   311   continue
 244 cgn      print *,lafin ,' = ',saux02
 245 c
 246       endif
 247 c
 248       endif
 249 c
 250 c 3.2. ==> format des valeurs et impressions
 251 c
 252       if ( codret.eq.0 ) then
 253 c
 254         if ( nomter.eq.nom ) then
 255           write (ulsort,texte(langue,9)) nomter, typtab
 256         else
 257           write (ulsort,texte(langue,10)) nomter, nom, typtab
 258         endif
 259         if ( len(chaine).gt.0 ) then
 260           write (ulsort,1000) chaine
 261         endif
 262 c
 263         if ( lgtabl.eq.0 ) then
 264           write (ulsort,texte(langue,4)) lgtabl
 265 c
 266         else
 267 c
 268           if ( partie ) then
 269             write (ulsort,texte(langue,15)) ledebu , lafin
 270           endif
 271 c
 272           iadr = iadr - 1
 273 c
 274           if ( typtab.eq.'entier  ' ) then
 275             entmax = 0
 276             entmin = 0
 277             do 312 , iaux = ledebu , lafin
 278               entmax = max (entmax,abs(imem(iadr+iaux)))
 279               entmin = min (entmin,imem(iadr+iaux))
 280   312       continue
 281             jaux = 10
 282             do 322 , iaux = 9 , 1 , -1
 283               if ( entmax.lt.10**iaux ) then
 284                 jaux = iaux
 285               endif
 286   322       continue
 287             if ( entmin.ne.0 ) then
 288               jaux = min(jaux+1,15)
 289             endif
 290             iaux = lgent + 3 + jaux
 291             iaux = (120-mod(120,iaux))/iaux
 292             if ( iaux.le.9 ) then
 293               write(fmtent(3:3),'(i1)') iaux
 294             else
 295               write(fmtent(2:3),'(i2)') iaux
 296             endif
 297             fmtent(6:7) = saux02
 298             if ( jaux.le.9 ) then
 299               write(fmtent(16:16),'(i1)') jaux
 300             else
 301               write(fmtent(16:17),'(i2)') jaux
 302             endif
 303             write (ulsort,fmtent)
 304      >             (iaux,imem(iadr+iaux),iaux=ledebu,lafin)
 305 c
 306           elseif ( typtab.eq.'chaine  ' ) then
 307             iaux = lgent + 3 + 8
 308             iaux = max(10,(120-mod(120,iaux))/iaux)
 309             write(fmtstr(2:3),'(i2)') iaux
 310             fmtstr(6:7) = saux02
 311             write (ulsort,fmtstr)
 312      >               (iaux,smem(iadr+iaux),iaux=ledebu,lafin)
 313 c
 314           elseif ( typtab.eq.'reel    ' ) then
 315             if (treel.eq.4) then
 316               fmt141(5:6) = saux02
 317               write (ulsort,fmt141)
 318      >               (iaux,rmem(iadr+iaux),iaux=ledebu,lafin)
 319             else
 320               fmt142(5:6) = saux02
 321               write (ulsort,fmt142)
 322      >               (iaux,rmem(iadr+iaux),iaux=ledebu,lafin)
 323             endif
 324 c
 325           endif
 326 c
 327 c                          1234567890123456789012345678901234567890
 328           saux80( 1:40) = '===   ===   ===   ===   ===   ===   === '
 329           saux80(41:80) = '  ===   ===   ===   ===   ===   ===   =='
 330           iaux = 16 + len(nom) + 3 + len(nomter) + 19
 331           write (ulsort,1100) saux80(1:min(80,iaux))
 332 c
 333         endif
 334 c
 335       endif
 336 c
 337 c====
 338 c 4. gestion des erreurs
 339 c====
 340 c
 341       if ( codret.ne.0 ) then
 342 c
 343 #ifdef _DEBUG_HOMARD_
 344         write (ulsort,90000)
 345         write (ulsort,texte(langue,1)) 'Sortie', nompro
 346         write (ulsort,texte(langue,2)) codret
 347 #endif
 348         write (ulsort,texte(langue,5)) nomter
 349         write (ulsort,*) nom
 350         if ( codret.eq.-6 ) then
 351           write (ulsort,texte(langue,4)) lgtabl
 352         endif
 353         if ( codret.eq.-5 .or. codret.eq.-6 ) then
 354           write (ulsort,texte(langue,20)) ideb, ifin
 355         else
 356           iaux = 15+abs(codret)
 357           write (ulsort,texte(langue,iaux))
 358         endif
 359 #ifdef _DEBUG_HOMARD_
 360         write (ulsort,90000)
 361 90000 format (70('='))
 362 #endif
 363 c
 364       endif
 365 c
 366       end