src/tool/Gestion_MTU/gagpmf.F

   1       subroutine gagpmf (objet, chemin, lgchem, nbchem,
   2      >                   ix, jx, nbrobj, nbrcha,
   3      >                   nomob, typob, adrch, nomco,
   4      >                   nballi, nomali,
   5      >                   nballr, nomalr,
   6      >                   nballs, nomals,
   7      >                   impopt, codret)
   8 c ______________________________________________________________________
   9 c
  10 c                             H O M A R D
  11 c
  12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  13 c
  14 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  15 c aupres des huissiers de justice Simart et Lavoir a Clamart
  16 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  17 c aupres des huissiers de justice
  18 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  19 c
  20 c    HOMARD est une marque deposee d'Electricite de France
  21 c
  22 c Copyright EDF 1996
  23 c Copyright EDF 1998
  24 c Copyright EDF 2002
  25 c Copyright EDF 2020
  26 c ______________________________________________________________________
  27 c
  28 c     construction du graphe d'un objet structure en memoire
  29 c     centrale ou sur fichier
  30 c
  31 c    de maniere generale, on a :
  32 c
  33 c      nbchem           = nombre de chemins pour l'objet
  34 c      lgchem(i)        = longueur du i-eme chemin
  35 c      chemin(i,2n-1)   = nom du n-eme champ du i-eme chemin
  36 c      chemin(i,2n)     = nom de l'objet associe a ce n-eme champ
  37 c      chemin(i,lgchem) = symbole pour le dernier champ :
  38 c                          * pour simple alloue
  39 c                          > pour structure alloue
  40 c                          = pour simple non alloue
  41 c                          + pour structure non alloue
  42 c                          - pour simple non defini
  43 c                          < pour structure non defini
  44 c ______________________________________________________________________
  45 c .        .     .        .                                            .
  46 c .  nom   . e/s . taille .           description                      .
  47 c .____________________________________________________________________.
  48 c . objet  . e   .  ch8   . nom de l'objet dont on doit construire le  .
  49 c .        .     .        . graphe                                     .
  50 c . chemin .  s  .(ix,jx) . tableau des chemins du graphe de l'objet   .
  51 c . lgchem .  s  .  ix    . longueur des chemins                       .
  52 c . nbchem .  s  .   1    . nombre de chemins                          .
  53 c . ix,jx  . e   .   1    . dimension du tableau chemin(.,.)           .
  54 c . nbrobj . e   .   1    . nombre d'objet enregistres                 .
  55 c . nbrcha . e   .   1    . nombre de champs                           .
  56 c . impopt . e   .   1    . 1 : on imprime le graphe ; 0 : non         .
  57 c . codret .  s  .   1    . code de retour :                           .
  58 c .        .     .        .  0    : OK                                 .
  59 c .        .     .        . -1    : dimensionnement insuffisant        .
  60 c .        .     .        . -2    : objet non structure                .
  61 c .____________________________________________________________________.
  62 c
  63 c====
  64 c 0. declarations et dimensionnement
  65 c====
  66 c
  67 c 0.1. ==> generalites
  68 c
  69       implicit none
  70       save
  71       character*6 nompro
  72       parameter ( nompro = 'GAGPMF' )
  73 c
  74 c
  75 #include "genbla.h"
  76 c
  77 #include "gmmatc.h"
  78 c
  79 c 0.2. ==> communs
  80 c
  81 #include "gmtori.h"
  82 #include "gmtors.h"
  83 c
  84 #include "gminds.h"
  85 #include "gmimpr.h"
  86 #include "gmlang.h"
  87 c
  88 c 0.3. ==> arguments
  89 c
  90       integer ix, jx, nbrobj, nbrcha, impopt, codret
  91       integer nballi, nballr, nballs
  92       integer nbchem, lgchem(ix)
  93 c
  94       integer typob(nbrobj), adrch(nbrobj)
  95 c
  96       character*(*) objet
  97       character*8 chemin(ix,jx)
  98       character*8 nomob(nbrobj), nomco(nbrcha)
  99       character*8 nomali(nballi)
 100       character*8 nomalr(nballr)
 101       character*8 nomals(nballs)
 102 c
 103 c 0.4. ==> variables locales
 104 c
 105       character*8 nomo
 106 c
 107       integer iaux,jaux,kaux,typo,nbch,icha,typc
 108       integer jn,noderc,n,k
 109       integer nroobj, posich
 110 c
 111       logical existc, encore, trouvc
 112 c
 113       integer nbmess
 114       parameter ( nbmess = 10 )
 115       character*80 texte(nblang,nbmess)
 116 c
 117 c 0.5. ==> initialisations
 118 c ______________________________________________________________________
 119 c
 120 c====
 121 c 1. messages
 122 c====
 123 c
 124 #include "impr01.h"
 125 c
 126 #ifdef _DEBUG_HOMARD_
 127       write (ulsort,texte(langue,1)) 'Entree', nompro
 128       call dmflsh (iaux)
 129 #endif
 130 c
 131       texte(1,4) = '('' * : objet simple alloue'')'
 132       texte(1,5) = '('' = : objet simple defini mais non alloue'')'
 133       texte(1,6) = '('' + : objet structure defini mais non alloue'')'
 134       texte(1,7) = '('' - : objet simple non defini'')'
 135       texte(1,8) = '('' < : objet structure non defini'')'
 136       texte(1,9) = '('' '')'
 137 c
 138       texte(2,4) = '('' * : allocated simple object'')'
 139       texte(2,5) = '('' = : defined but not allocated simple object'')'
 140       texte(2,6) =
 141      > '('' + : defined but not allocated structured object'')'
 142       texte(2,7) = '('' - : undefined simple object'')'
 143       texte(2,8) = '('' < : undefined structured object'')'
 144       texte(2,9) = '('' '')'
 145 c
 146 #ifdef _DEBUG_HOMARD_
 147       write (ulsort,90000)
 148         write (ulsort,texte(langue,1)) 'Sortie', nompro
 149 90000 format (70('='))
 150 #endif
 151 c
 152 c====
 153 c 2. initialisations
 154 c====
 155 c
 156       do 21 , iaux = 1,nbrobj
 157         if (nomob(iaux).eq.objet) then
 158           nroobj = iaux
 159           codret = 0
 160           goto 31
 161         endif
 162    21 continue
 163 c
 164       codret = -2
 165 c
 166 c====
 167 c 3. recherche de l'objet initial et de ses champs
 168 c====
 169 c
 170    31 continue
 171 c
 172       if ( codret.eq.0 ) then
 173 c
 174 c 3.1. ==> initialisation du chemin : a priori, il est indefini
 175 c          remarque : la boucle sur ix doit etre interne pour la
 176 c          vectorisation car ix >> jx
 177 c
 178         do 312 , jaux = 1,jx
 179           do 311 , iaux = 1,ix
 180             chemin(iaux,jaux) = sindef
 181   311     continue
 182   312   continue
 183 c
 184 c 3.2. ==> reperage des noms et type des champs de l'objet
 185 c
 186         typo = typob(nroobj)
 187         nbch = nbcham(typo)
 188 c
 189         do 32 , iaux = 1,nbch
 190 c
 191           icha = adrdst(typo)+iaux-1
 192           chemin(iaux,1) = nomcha(icha)
 193 c
 194           kaux = adrch(nroobj)+iaux-1
 195           chemin(iaux,2) = nomco(kaux)
 196 c
 197           typc = typcha(icha)
 198 c
 199           if (typc.lt.0) then
 200             chemin(iaux,3) = '*       '
 201           else
 202             chemin(iaux,3) = '>       '
 203           endif
 204 c
 205           lgchem(iaux) = 3
 206 c
 207    32    continue
 208 c
 209       endif
 210 c
 211 c====
 212 c 4.  construction du graphe
 213 c====
 214 c
 215       if ( codret.eq.0 ) then
 216 c
 217 c 4.1. ==> construction de l'arborescence
 218 c
 219         do 41 , jn = 1,jx
 220 c
 221 c 4.1.1. ==> recherche du numero du dernier champ defini : noderc
 222 c
 223           do 411 , iaux = 1,ix
 224             if (chemin(iaux,1).eq.sindef) then
 225               noderc = iaux-1
 226               goto 412
 227             endif
 228   411     continue
 229           write (ulsort,*) 'apres 411 continue'
 230           codret = -1
 231 c
 232   412     continue
 233 c
 234           if ( codret.eq.0 ) then
 235 c
 236 c 4.1.2. ==> nbchem est le nombre total de chemins a decrire :
 237 c            au depart, c'est le nombre de champs de l'objet demande.
 238 c            par ailleurs on signale que tout est fait
 239 c
 240             nbchem = noderc
 241             encore = .false.
 242 c
 243 c 4.1.3. ==> on explore chacun des champs de l'objet de depart, jusqu'a
 244 c          ce qu'il n'y ait plus que des champs simples
 245 c
 246             do 413 , iaux = 1,noderc
 247 c
 248 c 4.1.3.1. ==> recherche d'un champ de type structure dans le chemin
 249 c            s'il en existe un :
 250 c              . on repere sa position par posich
 251 c              . on signale qu'il faudra recommencer pour lui
 252 c
 253               do 431 , jaux = 3 , jx , 2
 254                 if (chemin(iaux,jaux)(1:1).eq.'>') then
 255                   posich = jaux
 256                   encore = .true.
 257                   existc = .true.
 258                   goto 432
 259                 endif
 260                 if (chemin(iaux,jaux)(1:1).eq.'*') then
 261                   existc = .false.
 262                   goto 432
 263                 endif
 264   431         continue
 265 c
 266 c 4.1.3.2. ==> on est sur un champ de type structure
 267 c
 268   432         continue
 269 c
 270               if ( existc ) then
 271 c
 272 c 4.1.3.2.1. ==> quel est le nom de ce champ ?
 273 c              . s'il n'est pas defini, on le symbolise par '<       '
 274 c              . s'il est defini on cherche son numero dans
 275 c                la liste des champs ; si on ne l'y trouve pas, on
 276 c                le symbolise par '+       '
 277 c
 278                 nomo = chemin(iaux,posich-1)
 279 c
 280                 if (nomo.eq.sindef) then
 281 c
 282                   chemin(iaux,posich) = '<       '
 283                   trouvc = .false.
 284 c
 285                 else
 286 c
 287                   do 433 , kaux = 1,nbrobj
 288                      if (nomob(kaux).eq.nomo) then
 289                         nroobj = kaux
 290                         trouvc = .true.
 291                         goto 434
 292                      endif
 293   433             continue
 294 c
 295                   chemin(iaux,posich) = '+       '
 296                   trouvc = .false.
 297 c
 298                 endif
 299 c
 300   434           continue
 301 c
 302 c 4.1.3.2.2. ==> le champ est defini : il faut ecrire sa descendance
 303 c              en fait, on fait comme a l'etape 2 pour l'objet de depart
 304 c                . pour le premier champ, on etend le chemin existant
 305 c                . pour les eventuels champs suivants, on cree autant
 306 c                  de nouveaux chemins en recopiant le debut
 307 c
 308                 if ( trouvc ) then
 309 c
 310                   if ( posich+2.gt.jx ) then
 311             write (ulsort,*) 'objet  = ',objet
 312             write (ulsort,*) 'dans 4.1.3.2.2, posich+2 = ',posich+2
 313             write (ulsort,*) 'dans 4.1.3.2.2, jx = ',jx
 314         do 1789 , n = 1,nbch
 315           write (ulsort,*)(chemin(n,k),k=1,jx)
 316  1789 continue
 317                      codret = -1
 318                      goto 42
 319                   endif
 320 c
 321 c                 on commence par ecrire les trois informations
 322 c                 de la fin du chemin en cours :
 323 c                 nom du champ, nom de l'objet associe, symbole
 324 c
 325                   typo = typob(nroobj)
 326                   nbch = nbcham(typo)
 327 c
 328                   icha = adrdst(typo)
 329                   chemin(iaux,posich) = nomcha(icha)
 330 c
 331                   kaux = adrch(nroobj)
 332                   chemin(iaux,posich+1) = nomco(kaux)
 333 c
 334                   typc = typcha(icha)
 335                   if (typc.lt.0) then
 336                      chemin(iaux,posich+2) = '*       '
 337                   else
 338                      chemin(iaux,posich+2) = '>       '
 339                   endif
 340 c
 341                   lgchem(iaux) = posich+2
 342 c
 343 c               ensuite, on cree les chemins associes aux eventuels
 344 c               champs suivants :
 345 c                 . on commence par mettre le debut
 346 c                 . puis on complete par les caracteristiques propres
 347 c                   au champ en cours
 348 c
 349                   do 435 , n = 1,nbch-1
 350 c
 351                      nbchem = nbchem+1
 352 c
 353                      do 436 , k = 1,posich-1
 354                         chemin(nbchem,k) = chemin(iaux,k)
 355   436                continue
 356 c
 357                      icha = adrdst(typo)+n
 358                      chemin(nbchem,posich) = nomcha(icha)
 359 c
 360                      kaux = kaux + 1
 361                      chemin(nbchem,posich+1) = nomco(kaux)
 362 c
 363                      typc = typcha(icha)
 364                      if (typc.lt.0) then
 365                         chemin(nbchem,posich+2) = '*       '
 366                      else
 367                         chemin(nbchem,posich+2) = '>       '
 368                      endif
 369 c
 370                      lgchem(nbchem) = posich+2
 371 c
 372   435             continue
 373 c
 374                 endif
 375 c
 376               endif
 377 c
 378   413       continue
 379 c
 380 c 4.1.3. ==> on a fini d'explorer une branche. on sort si c'est fini
 381 c
 382             if ( .not.encore ) then
 383               goto 42
 384             endif
 385 c
 386           endif
 387 c
 388    41    continue
 389 c
 390 c 4.2. ==> on controle les extremites des champs : celles qui
 391 c          correspondent a des objets simples definis mais non alloues
 392 c          sont signalees
 393 c
 394    42    continue
 395 c
 396          do 421 , iaux = 1 , nbchem
 397 c
 398             if ( chemin(iaux,lgchem(iaux))(1:1).eq.'*' ) then
 399 c
 400                nomo = chemin(iaux,lgchem(iaux)-1)
 401 c
 402                if ( nomo.eq.sindef ) then
 403 c
 404                   chemin(iaux,lgchem(iaux)) = '-       '
 405 c
 406                else
 407 c
 408                   trouvc = .false.
 409 c
 410                   do 422 , jaux = 1 , nballi
 411                      if (nomali(jaux).eq.nomo) then
 412                         trouvc = .true.
 413                         goto 429
 414                      endif
 415   422             continue
 416 c
 417                   do 423 , jaux = 1 , nballr
 418                      if (nomalr(jaux).eq.nomo) then
 419                         trouvc = .true.
 420                         goto 429
 421                      endif
 422   423             continue
 423 c
 424                   do 424 , jaux = 1 , nballs
 425                      if (nomals(jaux).eq.nomo) then
 426                         trouvc = .true.
 427                         goto 429
 428                      endif
 429   424             continue
 430 c
 431   429             continue
 432                   if ( .not.trouvc ) then
 433                      chemin(iaux,lgchem(iaux)) = '=       '
 434                   endif
 435 c
 436                endif
 437 c
 438             endif
 439 c
 440   421    continue
 441 c
 442       endif
 443 c
 444 c====
 445 c 5. impressions
 446 c====
 447 c
 448       if (impopt.eq.1) then
 449 c
 450       do 51 , iaux = 4, 9
 451         write (ulsort,texte(langue,iaux))
 452    51 continue
 453 c
 454       write (ulsort,*) ' '
 455       do 52 , iaux = 1 , nbchem
 456         kaux = min ( 10 , lgchem(iaux) )
 457         write (ulsort,5000) iaux,(chemin(iaux,jaux),jaux=1,kaux)
 458         if ( lgchem(iaux).gt.kaux ) then
 459           write (ulsort,5001)
 460      >    (chemin(iaux,jaux),jaux=kaux+1,lgchem(iaux))
 461         endif
 462         write (ulsort,*) ' '
 463    52 continue
 464 c
 465       write (ulsort,*) ' '
 466 c
 467  5000 format(i3,'-> ',10(1x,a8))
 468  5001 format(7x,10(1x,a8))
 469 c
 470       endif
 471 c
 472 #ifdef _DEBUG_HOMARD_
 473       write (ulsort,90000)
 474 #endif
 475 c
 476       end