src/tool/Gestion_MTU/gbitos.F

   1       subroutine gbitos ( nfdico, lfdico, codret)
   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     fonction d'initialisation des tables de description des
  23 c     types d'objet structure.
  24 c ______________________________________________________________________
  25 c .        .     .        .                                            .
  26 c .  nom   . e/s . taille .           description                      .
  27 c .____________________________________________________________________.
  28 c . nfdico . e   . ch<200 . nom du fichier des objets structures       .
  29 c . lfdico . e   .    1   . longueur du nom du fichier                 .
  30 c .        .     .        . si =0, on a les tables par gmitob          .
  31 c . codret .  s  .    1   . code de retour                             .
  32 c .        .     .        . -6 : impossible de decoder la date du      .
  33 c .        .     .        .      fichier des types                     .
  34 c .        .     .        . -5 : erreur : type interdit                .
  35 c .        .     .        . -4 : erreur : fichier de type d'objet vide .
  36 c .        .     .        . -3 : erreur : erreur de format dans le     .
  37 c .        .     .        .      fichier d'entree                      .
  38 c .        .     .        . -2 : erreur : type de champ non defini     .
  39 c .        .     .        . -1 : erreur : dimensionnement des tables   .
  40 c .        .     .        .      insuffisant                           .
  41 c .        .     .        .  0 : OK                                    .
  42 c .        .     .        .  3 ou 9 : fermeture impossible du fichier  .
  43 c ______________________________________________________________________
  44 c
  45 c====
  46 c 0. declarations et dimensionnement
  47 c====
  48 c
  49 c 0.1. ==> generalites
  50 c
  51       implicit none
  52       save
  53 c
  54       character*6 nompro
  55       parameter ( nompro = 'GBITOS' )
  56 c
  57 #include "genbla.h"
  58 c
  59 #include "gmmatc.h"
  60 c
  61 c 0.2. ==> communs
  62 c
  63 #include "gmtori.h"
  64 #include "gmtoai.h"
  65 #include "gmtors.h"
  66 #include "gmtoas.h"
  67 #include "gmtove.h"
  68 c
  69 #include "gminom.h"
  70 #include "gmtail.h"
  71 #include "gmindi.h"
  72 #include "gminds.h"
  73 c
  74 #include "gmimpr.h"
  75 #include "gmlang.h"
  76 c
  77 c 0.3. ==> arguments
  78 c
  79       character*(*) nfdico
  80 c
  81       integer lfdico, codret
  82 c
  83 c 0.4. ==> variables locales
  84 c
  85 #include "gmnelx.h"
  86 c
  87       integer lelm(nelx), nelm, lgtot, ns
  88       integer nftypo, ipart, ncham, ncha, iadr, it
  89       integer jaux, nrolig
  90       character*8 datefr, heurfr, textem
  91       character*80 chaine,elem(nelx)
  92 c
  93       integer iaux
  94 c
  95       character*1 sepa(4)
  96       character*8 chatyp(nchpx)
  97 c
  98       integer nbmess
  99       parameter ( nbmess = 20 )
 100       character*80 texte(nblang,nbmess)
 101 c
 102 c 0.5. ==> initialisations
 103 c
 104       data sepa / ' ' , ',' , ';' , ' ' /
 105 c
 106 c ______________________________________________________________________
 107 c
 108 c====
 109 c 1.  les messages
 110 c====
 111 c
 112 #include "impr01.h"
 113 c
 114 #ifdef _DEBUG_HOMARD_
 115       write (ulsort,texte(langue,1)) 'Entree', nompro
 116       call dmflsh (iaux)
 117 #endif
 118 c
 119       texte(1,17) = '(''Decodage du fichier typobj.stu :'')'
 120       texte(1,4) = '(''Erreur a la ligne numero'',i6,'' :'')'
 121       texte(1,5) =
 122      > '(''Le nombre maximum de types,'',i6,'' est atteint.'',/)'
 123       texte(1,6) =
 124      > '(''Le nombre maximum de champs,'',i6,'' est atteint.'',/)'
 125       texte(1,7) = '(''Fin de fichier inattendue.'',/)'
 126       texte(1,8) =
 127      > '(''Chaque texte doit avoir moins de 8 caracteres.'')'
 128       texte(1,9) = '(''Aucun type n''''a ete trouve ?'')'
 129       texte(1,10) = '(''Aucun type ne correspond au champ '',a8)'
 130       texte(1,11) = '(''Le nom de type '',a8,'' est interdit.'')'
 131       texte(1,12) = '(''Impossible de decoder la date '',a8)'
 132       texte(1,13) =
 133      > '(''ATTENTION : les deux premiers caracteres d''''un nom'')'
 134       texte(1,14) =
 135      > '(''de champ ne devraient pas etre deux chiffres : '',a8)'
 136       texte(1,15) = '(''... nom du type : '',a8)'
 137       texte(1,18) = '(/,''Dictionnaire des types d''''objets :'')'
 138       texte(1,19) = '(''. Version : '',i11)'
 139       texte(1,20) = '(''. Sous-version : '',i6,/,''. Date : '',a8)'
 140 c
 141       texte(2,17) = '(''Uncoding of file typobj.stu :'')'
 142       texte(2,4) = '(''Error on line #'',i6,'' :'')'
 143       texte(2,5) =
 144      > '(''The maximum number of types,'',i6,'' is reached.'',/)'
 145       texte(2,6) =
 146      > '(''The maximum number of fields,'',i6,'' is reached.'',/)'
 147       texte(2,7) = '(''Unexpected end of file.'',/)'
 148       texte(2,8) = '(''Each text must be less than 8 characters.'')'
 149       texte(2,9) = '(''No type was found ?'')'
 150       texte(2,10) = '(''No type is declared as field '',a8)'
 151       texte(2,11) =
 152      > '(''The name of this type '',a8,'' is forbidden.'')'
 153       texte(2,12) = '(''Date '',a8,'' cannot be uncoded.'')'
 154       texte(2,13) =
 155      > '(''WARNING : The first two characters of a field name'')'
 156       texte(2,14) =
 157      > '(''should not be both numeric : field name '',a8)'
 158       texte(2,15) = '(''... name of the type : '',a8)'
 159       texte(2,18) = '(/,''Object types dictionnary :'')'
 160       texte(2,19) = '(''. Version : '',i6)'
 161       texte(2,20) = '(''. Release : '',i6,/,''. Date : '',a8)'
 162 c
 163       codret = 0
 164 c
 165 c====
 166 c 2. - noms des types de base pour les donnees
 167 c      l'ordre des types doit etre respecte
 168 c    - les tailles des types de donnees sont en octets
 169 c====
 170 c
 171 c 2.1. ==> les noms des types de bases
 172 c
 173       ntyb = 3
 174 c
 175       nomtyb(1) = 'entier  '
 176       nomtyb(2) = 'reel    '
 177       nomtyb(3) = 'chaine  '
 178       nomtyb(4) = 'struct  '
 179 c
 180 c 2.2. ==> mise de l'information dans les noms de types de base
 181 c          et declares
 182 c
 183       do 21 iaux = 1 , ntybma
 184         nomtbp(-iaux) = nomtyb(iaux)
 185    21 continue
 186 c
 187 c 2.3. ==> les tailles des types de donnees sont en octets
 188 c
 189       call dmsize (tentie,treel,tchain)
 190 c
 191 c====
 192 c 3. initialisation a des valeurs non definies des differents tableaux
 193 c    decrivant les types et les champs declares et des numeros de
 194 c    version et de sous-version
 195 c====
 196 c
 197       do 31 iaux = 1 , ntypx
 198          nomtbp(iaux) = sindef
 199          nomtyp(iaux) = sindef
 200          nbcham(iaux) = iindef
 201          nbratt(iaux) = iindef
 202          adrdst(iaux) = iindef
 203    31 continue
 204 c
 205       do 32 iaux = 1 , nchpx
 206          chatyp(iaux) = sindef
 207          nomcha(iaux) = sindef
 208          typcha(iaux) = iindef
 209    32 continue
 210 c
 211       nuveto = iindef
 212       nusvto = iindef
 213       daheto = iindef
 214       nuanto = iindef
 215 c
 216 c====
 217 c 4. initialisation des tables d'objets
 218 c====
 219 c
 220       if ( lfdico.eq.0 ) then
 221 c
 222 cgn      write (ulsort,*) 'appel de gmitob'
 223 c
 224         call gmitob
 225 c
 226 c====
 227 c 4. lecture  du fichier de declaration des types d'objets
 228 c====
 229 c
 230       else
 231 c
 232       call guoufs ( nfdico, lfdico, nftypo, codret )
 233 c
 234       nrolig = 0
 235 c
 236       ns = 3
 237       codret = 0
 238       nbrtyp = 0
 239       adrdst(1) = 1
 240 c
 241 c 4.1. ==> boucle 41 : jusqu'a ce que la ligne demarre par le
 242 c          bon mot-cle
 243 c
 244    41 continue
 245 c
 246       nrolig = nrolig + 1
 247       read (nftypo,'(a)',end=50) chaine
 248 c
 249       call gbpart(chaine,elem,lelm,nelm,lgtot,sepa,ns,ipart)
 250 c
 251       if ( ipart.eq.-1 ) then
 252         goto 41
 253       else
 254         if ( elem(1)(1:6).eq.'>>TYPE' ) then
 255           jaux = 1
 256           goto 42
 257         else if ( elem(1)(1:9).eq.'>>VERSION' ) then
 258           jaux = 2
 259           goto 42
 260         else
 261           goto 41
 262         endif
 263       endif
 264 c
 265 c 4.2. ==> boucle 42 : jusqu'a ce que la ligne ne soit ni blanche,
 266 c          ni un commentaire.
 267 c          quand c'est bon, elle contient la description d'un type
 268 c          ou de la version
 269 c
 270    42 continue
 271 c
 272 c 4.2.1 ==> lecture de la ligne suivante
 273 c
 274       nrolig = nrolig + 1
 275       read (nftypo,'(a)',end=73) chaine
 276 c
 277       call gbpart(chaine,elem,lelm,nelm,lgtot,sepa,ns,ipart)
 278 c
 279       if ( (ipart.eq.-1) .or. (elem(1)(1:2).eq.'$$') ) then
 280          goto 42
 281       endif
 282 c
 283 c 4.2.2. ==> controle de la longueur de chacun des textes
 284 c
 285       if ( lelm(1).gt.8 .or.
 286      >     lelm(2).gt.8 .or.
 287      >     lelm(3).gt.8 ) then
 288          goto 74
 289       endif
 290 c
 291 c 4.2.3. ==> decodage d'un type
 292 c
 293       if ( jaux.eq.1 ) then
 294 c
 295 c 4.2.3.1. ==> les trois termes de la chaine :
 296 c              1 : nom du type
 297 c              2 : nombre de champs
 298 c              3 : nombre d'attributs
 299 c
 300         nbrtyp = nbrtyp+1
 301         if (nbrtyp.gt.ntypx) then
 302            goto 71
 303         endif
 304 c
 305         nomtyp(nbrtyp) = elem(1)(1:8)
 306 c
 307         read (elem(2),'(i8)') ncham
 308         nbcham(nbrtyp) = ncham
 309 c
 310         read (elem(3),'(i8)') nbratt(nbrtyp)
 311 c
 312         if (nbrtyp.gt.1) then
 313            adrdst(nbrtyp) = adrdst(nbrtyp-1)+nbcham(nbrtyp-1)
 314         endif
 315 c
 316 c 4.2.3.2. ==> controle du nom du type
 317 c
 318         do 4232 iaux = 1 , ntybma
 319            if ( nomtyp(nbrtyp).eq.nomtyb(iaux) ) then
 320               codret = -3
 321               write (ulsort,texte(langue,17))
 322               write (ulsort,*) nfdico
 323               write (ulsort,texte(langue,11)) nomtyp(nbrtyp)
 324            endif
 325  4232   continue
 326 c
 327         nomtbp(nbrtyp) = nomtyp(nbrtyp)
 328 c
 329 c 4.2.3.3. ==> boucle 4233 : decodage de chacun des champs du type
 330 c          jusqu'a ce que les ncham champs aient ete lus.
 331 c          quand c'est fini, on repasse a une nouvelle ligne (goto 41)
 332 c
 333         ncha = 0
 334 c
 335  4233   continue
 336 c
 337         nrolig = nrolig + 1
 338         read (nftypo,'(a)',end=73) chaine
 339 c
 340         call gbpart(chaine,elem,lelm,nelm,lgtot,sepa,ns,ipart)
 341 c
 342         if ( (ipart.eq.-1) .or. (elem(1)(1:2).eq.'$$') ) then
 343            goto 4233
 344         endif
 345         if ( (ncha.eq.ncham) .and. (elem(1)(1:5).eq.'>>FIN') ) then
 346            goto 41
 347         endif
 348         if ( (lelm(1).gt.8) .or. (lelm(2).gt.8) ) then
 349            goto 74
 350         endif
 351 c
 352         iadr = adrdst(nbrtyp)+ncha
 353         if (iadr.gt.nchpx) then
 354            goto 72
 355         endif
 356         nomcha(iadr) = elem(1)(1:8)
 357 c
 358 c les deux premiers caracteres d'un nom de champ ne devraient pas etre
 359 c tous deux numeriques : risque de conflit entre generateurs de noms
 360 c d'objets (temporaires, cf. gbntcr, et voir aussi les sous-programmes
 361 c gbgeno). Au mieux, cela risque de ralentir l'execution ...
 362 c ... cela dit, on ne fait qu'imprimer un avertissement.
 363 c
 364         if ( index('0123456789',nomcha(iadr)(1:1)).gt.0 .and.
 365      >       index('0123456789',nomcha(iadr)(2:2)).gt.0 ) then
 366           write (ulsort,texte(langue,1)) 'Sortie', nompro
 367           write (ulsort,texte(langue,17))
 368           write (ulsort,*) nfdico
 369           write (ulsort,texte(langue,13))
 370           write (ulsort,texte(langue,14)) nomcha(iadr)
 371           write (ulsort,texte(langue,15)) nomtbp(nbrtyp)
 372         endif
 373 c
 374         chatyp(iadr) = elem(2)(1:8)
 375         ncha = ncha+1
 376 c
 377         goto 4233
 378 c
 379 c 4.2.4. ==> decodage de la reference de la version
 380 c
 381       else if ( jaux.eq.2 ) then
 382 c
 383 c 4.2.4.1. ==> le numero de version
 384 c
 385         if ( elem(1)(1:5).eq.'>>FIN' ) then
 386           goto 41
 387 c
 388         else
 389 c
 390           if ( elem(1)(1:7).eq.'Version' ) then
 391             read (elem(2),'(i8)') nuveto
 392 c
 393           else if ( elem(1)(1:8).eq.'SousVers' ) then
 394             read (elem(2),'(i8)') nusvto
 395 c
 396           else if ( elem(1)(1:4).eq.'Date' ) then
 397             datefr = '        '
 398             datefr(1:2) = elem(2)(1:2)
 399             datefr(4:5) = elem(3)(1:2)
 400             datefr(7:8) = elem(4)(1:2)
 401 c
 402           endif
 403 c
 404           goto 42
 405 c
 406         endif
 407 c
 408       endif
 409 c
 410 c====
 411 c 5. enregistrement des informations
 412 c====
 413 c
 414    50 continue
 415 c
 416 c 5.1. ==> decodage du type de chaque champ
 417 c
 418       if (nbrtyp.ne.0) then
 419 c
 420 c 5.1.1. ==> decodage du type de chaque champ
 421 c
 422          do 51 iaux = 1, nbrtyp
 423 c
 424             do 511 jaux = adrdst(iaux), adrdst(iaux)+nbcham(iaux)-1
 425 c
 426                call gbminu(chatyp(jaux),textem)
 427 c
 428                if (textem.eq.nomtyb(1)) then
 429                   typcha(jaux) = -1
 430                else if (textem.eq.nomtyb(2)) then
 431                   typcha(jaux) = -2
 432                else if (textem.eq.nomtyb(3)) then
 433                   typcha(jaux) = -3
 434                else
 435 c
 436                   do 5111 it = 1, nbrtyp
 437                      if (nomtyp(it).eq.chatyp(jaux)) then
 438                         typcha(jaux) = it
 439                         goto 511
 440                      endif
 441  5111             continue
 442 c
 443                   write (ulsort,texte(langue,1)) 'Sortie', nompro
 444                   write (ulsort,texte(langue,17))
 445                   write (ulsort,*) nfdico
 446                   write (ulsort,texte(langue,10)) chatyp(jaux)
 447                   codret = -2
 448                   goto 80
 449 c
 450                endif
 451   511       continue
 452 c
 453    51    continue
 454 c
 455       else
 456 c
 457 c 5.2. ==> probleme : aucun type n'a ete trouve dans le fichier
 458 c
 459          write (ulsort,texte(langue,1)) 'Sortie', nompro
 460          write (ulsort,texte(langue,17))
 461          write (ulsort,*) nfdico
 462          write (ulsort,texte(langue,9))
 463          codret = -4
 464          goto 80
 465 c
 466       endif
 467 c
 468 c====
 469 c 6. enregistrement de la date des types d'objets
 470 c====
 471 c
 472       heurfr = '00:00:00'
 473       iaux = 0
 474 c
 475       call ugdhfc ( daheto, nuanto,
 476      >              datefr, heurfr,
 477      >              iaux )
 478 c
 479       if ( iaux.ne.0 ) then
 480         goto 75
 481       endif
 482 c
 483       goto 80
 484 c
 485 c====
 486 c 7. gestion des messages d'erreur
 487 c====
 488 c
 489    71 continue
 490       write (ulsort,texte(langue,1)) 'Sortie', nompro
 491       write (ulsort,texte(langue,17))
 492       write (ulsort,*) nfdico
 493       write (ulsort,texte(langue,4)) nrolig
 494       write (ulsort,*) chaine
 495       write (ulsort,texte(langue,5)) ntypx
 496       codret = -1
 497       goto 80
 498 c
 499    72 continue
 500       write (ulsort,texte(langue,1)) 'Sortie', nompro
 501       write (ulsort,texte(langue,17))
 502       write (ulsort,*) nfdico
 503       write (ulsort,texte(langue,4)) nrolig
 504       write (ulsort,*) chaine
 505       write (ulsort,texte(langue,6)) nchpx
 506       codret = -1
 507       goto 80
 508 c
 509    73 continue
 510       write (ulsort,texte(langue,1)) 'Sortie', nompro
 511       write (ulsort,texte(langue,17))
 512       write (ulsort,*) nfdico
 513       write (ulsort,texte(langue,4)) nrolig
 514       write (ulsort,*) chaine
 515       write (ulsort,texte(langue,7))
 516       codret = -3
 517       goto 80
 518 c
 519    74 continue
 520       write (ulsort,texte(langue,1)) 'Sortie', nompro
 521       write (ulsort,texte(langue,17))
 522       write (ulsort,*) nfdico
 523       write (ulsort,texte(langue,4)) nrolig
 524       write (ulsort,*) chaine
 525       write (ulsort,texte(langue,8))
 526       codret = -3
 527       goto 80
 528 c
 529    75 continue
 530       write (ulsort,texte(langue,1)) 'Sortie', nompro
 531       write (ulsort,texte(langue,17))
 532       write (ulsort,*) nfdico
 533       write (ulsort,texte(langue,12)) datefr
 534       codret = -6
 535       goto 80
 536 c
 537 c====
 538 c 8. fermer le fichier dictionnaire
 539 c====
 540 c
 541    80 continue
 542 c
 543       call gufefi ( nfdico, lfdico, codret )
 544 c
 545       endif
 546 c
 547 #ifdef _DEBUG_HOMARD_
 548       write (ulsort,texte(langue,18))
 549       write (ulsort,texte(langue,19)) nuveto
 550       write (ulsort,texte(langue,20)) nusvto, datefr
 551 #endif
 552 c
 553 c====
 554 c 9. initialisation des quantites gerant les objets alloues
 555 c               les tables    : nomobj , nomobc
 556 c               les pointeurs : iptobj , iptchp
 557 c                          et : indnom , iptatt
 558 c     attention : il vaut mieux initialiser les attributs
 559 c     a une valeur indefinie, ca evite des surprises ...
 560 c====
 561 c
 562       do 91 iaux = 1, nobjx
 563         typobj(iaux) = iindef
 564         adrdso(iaux) = iindef
 565         adrdsa(iaux) = iindef
 566         nomobj(iaux) = sindef
 567    91 continue
 568 c
 569       do 92 iaux = 1, nobcx
 570         nomobc(iaux) = sindef
 571         valatt(iaux) = iindef
 572    92 continue
 573 c
 574       iptobj = 1
 575       iptchp = 1
 576       iptatt = 1
 577       indnom = 0
 578 c
 579       end