src/tool/Gestion_MTU/gmprsx.F

   1       subroutine gmprsx ( chaine, nom )
   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 d'un objet
  23 c       . si l'objet est structure, on imprime ses attributs
  24 c       . si l'objet est simple, on imprime son contenu complet
  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 ______________________________________________________________________
  32 c
  33 c====
  34 c 0. declarations et dimensionnement
  35 c====
  36 c
  37 c 0.1. ==> generalites
  38 c
  39       implicit none
  40       save
  41 c
  42       character*6 nompro
  43       parameter ( nompro = 'GMPRSX' )
  44 c
  45 #include "genbla.h"
  46 c
  47 #include "gmmatc.h"
  48 c
  49 c 0.2. ==> communs
  50 c
  51 #include "gmtori.h"
  52 #include "gmtoai.h"
  53 #include "gmtoas.h"
  54 #include "gmtors.h"
  55 c
  56 #include "gmimpr.h"
  57 #include "gmlang.h"
  58 c
  59 c 0.3. ==> arguments
  60 c
  61       character*(*) chaine
  62       character*(*) nom
  63 c
  64 c 0.4. ==> variables locales
  65 c
  66       integer nba, nbc, letype
  67       integer adsa, adso, adst
  68       integer iaux, jaux, ideb, ifin
  69       integer codret
  70 c
  71       character*8 nomter, typtab, nocham
  72 c
  73       integer nbmess
  74       parameter ( nbmess = 10 )
  75       character*80 texte(nblang,nbmess)
  76 c
  77 c 0.5. ==> initialisations
  78 c ______________________________________________________________________
  79 c
  80 c====
  81 c 1. messages
  82 c====
  83 c
  84 #include "impr01.h"
  85 c
  86 #ifdef _DEBUG_HOMARD_
  87       write (ulsort,texte(langue,1)) 'Entree', nompro
  88       call dmflsh (iaux)
  89 #endif
  90 c
  91       texte(1,5) = '(a)'
  92       texte(1,4) =
  93      > '(/,''=== Structure '',a8,'' de type '',a8,'' ==='',/)'
  94       texte(1,6) = '(''Attribut numero'',i6,'' : '',i15)'
  95       texte(1,7) = '(''Champ numero   '',i6,'' : '',a8)'
  96       texte(1,8) = '(''  Type : '',a8,'' --> objet associe : '',a8)'
  97       texte(1,9) = '(''==> le nom de cette structure est invalide.'',/)'
  98       texte(1,10) = '(''==> cette structure n''''est pas allouee.'',/)'
  99 c
 100       texte(2,5) = '(a)'
 101       texte(2,4) ='(/,''=== Structure '',a8,'' : Type '',a8,'' ==='',/)'
 102       texte(2,6) = '(''Attribute #'',i6,'' : '',i15)'
 103       texte(2,7) = '(''Field #    '',i6,'' : '',a8)'
 104       texte(2,8) = '(''  Type : '',a8,'' --> related object : '',a8)'
 105       texte(2,9) = '(''The name of this structure is not valid.'',/)'
 106       texte(2,10) = '(''==> this structure is not allocated.'',/)'
 107 c
 108 c====
 109 c 2. etat de l'objet en memoire
 110 c====
 111 c
 112       call gmobal ( nom, codret )
 113 c
 114 c====
 115 c 3. si objet non alloue
 116 c====
 117 c
 118       if ( codret.eq.0 ) then
 119 c
 120         write (ulsort,*) ' '
 121         write (ulsort,*) nom
 122         write (ulsort,texte(langue,10))
 123 c
 124 c====
 125 c 4. decodage des attributs pour un objet structure
 126 c====
 127 c
 128       elseif ( codret.eq.1 ) then
 129 c
 130 c 4.1. ==> recherche du nom terminal de l'objet et de son type
 131 c
 132         call gmtyoj ( nom, typtab, iaux, codret )
 133 c
 134         call gmnomc ( nom, nomter, codret )
 135 c
 136 c 4.2. ==> recherche du numero de l'objet
 137 c
 138         do 42 , iaux = 1 , iptobj-1
 139           if ( nomobj(iaux).eq.nomter ) then
 140             letype = iaux
 141             nba = nbratt(typobj(letype))
 142             nbc = nbcham(typobj(letype))
 143             adsa = adrdsa(letype)
 144             adso = adrdso(letype)
 145             adst = adrdst(typobj(letype))
 146             goto 431
 147           endif
 148    42   continue
 149 c
 150         goto 440
 151 c
 152 c 4.3. ==> ecriture des attributs
 153 c
 154   431   continue
 155 c
 156         write (ulsort,texte(langue,4)) nomter, typtab
 157         if ( len(chaine).gt.0 ) then
 158           write (ulsort,texte(1,5)) chaine
 159         endif
 160         write (ulsort,*) nom
 161         write (ulsort,*) ' '
 162 c
 163         do 432 , iaux = 1 , nba
 164           write(ulsort,texte(langue,6)) iaux, valatt(adsa+iaux-1)
 165   432   continue
 166 c
 167         do 433 , iaux = 1 , nbc
 168           jaux = typcha(adst+iaux-1)
 169           if ( jaux.gt.0 ) then
 170             nocham = nomtyp(jaux)
 171           else
 172             nocham = nomtyb(abs(jaux))
 173           endif
 174           write(ulsort,texte(langue,7)) iaux, nomcha(adst+iaux-1)
 175           write(ulsort,texte(langue,8)) nocham, nomobc(adso+iaux-1)
 176   433   continue
 177 c
 178   440   continue
 179 c
 180 c====
 181 c 5. appel du programme generique pour un objet simple
 182 c====
 183 c
 184       elseif ( codret.eq.2 ) then
 185 c
 186         ideb = 0
 187         ifin = 0
 188         call gmprot ( chaine, nom, ideb, ifin )
 189 c
 190 c====
 191 c 6. si objet non defini
 192 c====
 193 c
 194       else
 195 c
 196         write (ulsort,*) ' '
 197         write (ulsort,*) nom
 198         write (ulsort,texte(langue,9))
 199 c
 200       endif
 201 c
 202       end