src/tool/Gestion_MTU/gbcara.F

   1       subroutine gbcara  ( nomtab , nrotab, adut , ilong , type8 )
   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 .  derniere modif octo 93 at prise en compte du type simple precision
  23 c .           modif octo 93 gn prise en compte du type double precision
  24 c .           modif juin 93 jyb prise en compte du type character*8
  25 c .           modif 15/06/89 jc jyb
  26 c ......................................................................
  27 c .       recherche les caracteristiques d'un tableau (position,longueur
  28 c .     et type ) a partir de son nom. retourne un code d'erreur si le
  29 c .     nom n'est pas repertorie ou si il y a ambiguite.
  30 c ______________________________________________________________________
  31 c .        .     .        .                                            .
  32 c .  nom   . e/s . taille .           description                      .
  33 c .____________________________________________________________________.
  34 c . nomtab . e   . ch*8   . nom du tableau a rechercher                .
  35 c . nrotab .  s  .   1    . numero du tableau dans sa categorie        .
  36 c . adut   .  s  .   1    . adresse de debut de tableau dans le maxi-  .
  37 c .        .     .        . tableau associe a son type                 .
  38 c . ilong  .  s  .   1    . dimension du tableau                       .
  39 c . type8  .  s  . ch*8   . type de tableau ou probleme rencontre      .
  40 c . coergm .  s  .    1   . code de retour d'erreur                    .
  41 c .        .     .        . 0 tableau trouve                           .
  42 c .        .     .        . 1 tableau non trouve                       .
  43 c .        .     .        . 2 tableau repertorie plusieurs fois reel   .
  44 c .        .     .        . 3 tableau repertorie plusieurs fois ent    .
  45 c .        .     .        . 4 tableau repertorie plusieurs fois simp   .
  46 c .        .     .        . 5 tableau repertorie plusieurs fois char   .
  47 c .        .     .        . 6 tableau repertorie plusieurs fois comp   .
  48 c .        .     .        . 7 tableau repertorie dans deux types       .
  49 c ______________________________________________________________________
  50 c
  51 c====
  52 c 0. declarations et dimensionnement
  53 c====
  54 c
  55 c 0.1. ==> generalites
  56 c
  57       implicit none
  58       save
  59       character*6 nompro
  60       parameter ( nompro = 'GBCARA' )
  61 c
  62 #include "genbla.h"
  63 #include "gmmaxt.h"
  64 c
  65 c 0.2. ==> communs
  66 c
  67 #include "gmtail.h"
  68 #include "gmtyge.h"
  69 c
  70 #include "gmtrrl.h"
  71 #include "gmtren.h"
  72 #include "gmtrst.h"
  73 c
  74 #include "gmalrl.h"
  75 #include "gmalen.h"
  76 #include "gmalst.h"
  77 c
  78 #include "envex1.h"
  79 #include "gmcoer.h"
  80 #include "gmimpr.h"
  81 #include "gmlang.h"
  82 c
  83 c 0.3. ==> arguments
  84 c
  85       character*8 nomtab
  86       character*8 type8
  87 c
  88       integer nrotab, adut , ilong
  89 c
  90 c 0.4. ==> variables locales
  91 c
  92       character*8 nomvar
  93 c
  94       integer iaux
  95       integer icpti, icptr, icpts
  96       integer i, iadd
  97       integer ltype, ad0, ad1
  98       integer nbcain
  99 c
 100       integer nbmess
 101       parameter ( nbmess = 20 )
 102       character*80 texte(nblang,nbmess)
 103 c
 104       character*1 carint(1)
 105 c
 106 c 0.5. ==> initialisations
 107 c
 108       data nbcain     / 0 /
 109 c
 110       data carint(1) / ' ' /
 111 c ______________________________________________________________________
 112 c
 113 c====
 114 c 1. messages
 115 c====
 116 c
 117 #include "impr01.h"
 118 c
 119 #ifdef _DEBUG_HOMARD_
 120       write (ulsort,texte(langue,1)) 'Entree', nompro
 121       call dmflsh (iaux)
 122 #endif
 123 c
 124       texte(1,10) =
 125      > '(''Nom de l''''objet a rechercher en memoire centrale :'')'
 126       texte(1,11) = '(''L''''objet n''''est pas alloue.'')'
 127       texte(1,12) = '(''Present plusieurs fois dans les reels.'')'
 128       texte(1,13) = '(''Present plusieurs fois dans les entiers.'')'
 129       texte(1,14) = '(''Present plusieurs fois dans les chaines.'')'
 130       texte(1,15) = '(''Present dans deux types.'')'
 131       texte(1,18) = '(''Mode de gestion de la memoire inconnu.'')'
 132       texte(1,20) = '(''Le nom est incorrect.'')'
 133 c
 134       texte(2,10) =
 135      > '(''Name of the wanted object in central memory :'')'
 136       texte(2,11) = '(''The object is not allocated.'')'
 137       texte(2,12) = '(''Present several times in reals.'')'
 138       texte(2,13) = '(''Present several times in integers.'')'
 139       texte(2,14) = '(''Present several times in character.'')'
 140       texte(2,15) = '(''Present in two types.'')'
 141       texte(2,18) = '(''Unknown memory management mode.'')'
 142       texte(2,20) = '(''Name is uncorrect.'')'
 143 c
 144 #ifdef _DEBUG_HOMARD_
 145 c      write (ulsort,90000)
 146       write (ulsort,texte(langue,10))
 147       write (ulsort,*) nomtab
 148 #endif
 149 c
 150 c====
 151 c 1. verifications
 152 c====
 153 c
 154       call gmntve ( nomtab, nomvar, nbcain, carint, coergm )
 155 c
 156 cgn      write (ulsort,*) coergm
 157       if ( coergm.ne.0 ) then
 158         coergm = 10
 159       endif
 160 c
 161 c====
 162 c 2. recherche du nombre d'occurences dans les tableaux
 163 c    entiers, reels et character*8
 164 c====
 165 #ifdef _DEBUG_HOMARD_
 166       write (ulsort,*) '2. Recherche ; coergm = ', coergm
 167 #endif
 168 c
 169       if ( coergm.eq.0 ) then
 170 c
 171          nrotab  = 0
 172 c
 173          icpti = 0
 174          do 21  i = 1, nballi
 175            if ( nomvar.eq.nomali(i) ) then
 176               icpti = icpti + 1
 177               nrotab  = i
 178            endif
 179    21    continue
 180 c
 181          icptr = 0
 182          do 22  i = 1, nballr
 183            if ( nomvar.eq.nomalr(i) ) then
 184               icptr = icptr + 1
 185               nrotab  = i
 186            endif
 187    22    continue
 188 c
 189          icpts = 0
 190          do 23  i = 1, nballs
 191            if ( nomvar.eq.nomals(i) ) then
 192               icpts = icpts + 1
 193               nrotab  = i
 194            endif
 195    23    continue
 196 c
 197       endif
 198 c
 199 c====
 200 c 3. bilan de la recherche
 201 c====
 202 #ifdef _DEBUG_HOMARD_
 203       write (ulsort,*) '3. Bilan de la recherche ; coergm = ', coergm
 204 #endif
 205 c
 206       if ( coergm.eq.0 ) then
 207 c
 208 c 3.1. ==> cas sympa : le tableau n'apparait qu'une seule fois
 209 c
 210       if ( (icptr + icpti + icpts).eq.1 ) then
 211 c
 212 c 3.1.1. ==> chez les entiers
 213 c
 214          if ( icpti.eq.1 ) then
 215 c
 216            iadd   =  ptalli (nrotab)
 217            ilong  =  lgalli (nrotab)
 218            type8  = 'entier  '
 219            ltype = tentie
 220            ad0 = adcom(1)
 221            ad1 = admem(1)
 222 c
 223 c 3.1.2. ==> chez les reels double precison
 224 c
 225          elseif ( icptr.eq.1 ) then
 226            iadd   =  ptallr (nrotab)
 227            ilong  =  lgallr (nrotab)
 228            type8  = 'reel    '
 229            ltype = treel
 230            ad0 = adcom(2)
 231            ad1 = admem(2)
 232 c
 233 c 3.1.3. ==> chez les character*8
 234 c
 235          elseif ( icpts.eq.1 ) then
 236 c
 237            iadd   =  ptalls (nrotab)
 238            ilong  =  lgalls (nrotab)
 239            type8  = 'chaine  '
 240            ltype = tchain
 241            ad0 = adcom(3)
 242            ad1 = admem(3)
 243 c
 244          endif
 245 c
 246 c 3.1.6. ==> correction de l'adresse utile
 247 c
 248          if ( modgm.eq.0 ) then
 249             adut = ((ad1-ad0)/ltype) + iadd
 250             coergm = 0
 251          else if ( modgm.eq.1 ) then
 252             adut = ((ad1-ad0)/ltype) + iadd + 1
 253             coergm = 0
 254          else if ( modgm.eq.2 ) then
 255 c
 256 c mode dynamique :
 257 c
 258             adut = (iadd-ad0)/ltype
 259 c
 260 c en particulier pour les "gros types",
 261 c on n'a pas vraiment de garantie que la division precedente
 262 c "tombe juste". Le fait d'avoir en fait alloue un peu plus grand
 263 c (cf. appel a gbalme dans gmalog) permet de se mettre a l'abris
 264 c de ce genre de probleme (entre autres).
 265 c
 266             if ( adut*ltype .ge. iadd-ad0 ) then
 267               adut = adut + 1
 268             else
 269               adut = adut + 2
 270             endif
 271 c
 272             coergm = 0
 273 c
 274          else
 275             coergm = 8
 276          endif
 277 c
 278       else
 279 c
 280 c 3.2. ==> autres cas : mise a zero des grandeurs puis messages
 281 c
 282 c 3.2.1. ==> mise a zero des grandeurs
 283 c
 284          iadd   =  0
 285          ilong  =  0
 286 c
 287 c 3.2.2. ==> 1er cas : le tableau n'apparait pas
 288 c
 289          if ( (icpti + icptr + icpts).eq.0 ) then
 290            type8  = 'absent  '
 291            coergm = 1
 292          endif
 293 c
 294 c 3.2.3. ==> Cas pas sympa : ou le tableau apparait plusieurs fois
 295 c
 296 c 3.2.3.1. ==> dans les reels
 297 c
 298          if ( icptr .gt. 1 ) then
 299            coergm = 2
 300            type8  = 'multip  '
 301          endif
 302 c
 303 c 3.2.3.2. ==> dans les entiers
 304 c
 305          if ( icpti .gt. 1 ) then
 306            coergm = 3
 307            type8  = 'multip  '
 308          endif
 309 c
 310 c 3.2.3.3. ==> dans les character*8
 311 c
 312          if ( icpts .gt. 1 ) then
 313            coergm = 4
 314            type8  = 'multip  '
 315          endif
 316 c
 317 c 3.2.3.4. ==> dans deux categories
 318 c
 319          if ( (icptr*icpti).ne.0 ) then
 320            coergm = 5
 321            type8  = 'multip  '
 322          endif
 323 c
 324          if ( (icptr*icpts).ne.0 ) then
 325            coergm = 5
 326            type8  = 'multip  '
 327          endif
 328 c
 329          if ( (icpti*icpts).ne.0 ) then
 330            coergm = 5
 331            type8  = 'multip  '
 332          endif
 333 c
 334       endif
 335 c
 336       endif
 337 c
 338 c====
 339 c 4. gestion des erreurs
 340 c====
 341 c
 342       if ( coergm.ne.0 ) then
 343 cgn          write(1,*)coergm
 344 c
 345          iaux = 10+abs(coergm)
 346 c
 347 #ifdef _DEBUG_HOMARD_
 348          write (ulsort,texte(langue,iaux))
 349 #endif
 350 c
 351          if ( iaux.eq.20 ) then
 352 #include "envex2.h"
 353             call ugstop('gbcara',ulsort,1,1,1)
 354          endif
 355 c
 356       endif
 357 c
 358 #ifdef _DEBUG_HOMARD_
 359       write (ulsort,90000)
 360 90000 format (70('='))
 361 c
 362 #endif
 363 c
 364       end