1 subroutine gmprot ( chaine, nom, ideb, ifin )
2 c ______________________________________________________________________
6 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
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
14 c HOMARD est une marque deposee d'Electricite de France
20 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 ______________________________________________________________________
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 ______________________________________________________________________
36 c 0. declarations et dimensionnement
39 c 0.1. ==> generalites
45 parameter ( nompro = 'GMPROT' )
70 c 0.4. ==> variables locales
77 character*45 fmt131, fmt132
78 character*45 fmt141, fmt142
79 character*45 fmt151, fmt152
84 integer iadr, codret, lgtabl, entmax, entmin
85 integer ledebu, lafin, nrotab
90 parameter ( nbmess = 20 )
91 character*80 texte(nblang,nbmess)
93 c 0.5. ==> initialisations
94 c ______________________________________________________________________
102 #ifdef _DEBUG_HOMARD_
103 write (ulsort,texte(langue,1)) 'Entree', nompro
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)'
111 >'(''=== Structure '',a8,'', type '',a8,'' ==='')'
113 >'(''=== Structure '',a8,'' / '',a,'', type '',a8,'' ==='')'
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.'',/)'
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)'
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)
129 > '(''Partial impression between indices '',i10,'' et '',i10)'
130 texte(2,16) = '(''This object is not available.'',/)'
131 texte(2,17) = '(''Bad object name.'',/)'
133 > '(''This object is structured ? or is not available ?'')'
134 texte(2,19) = '(''This object is defined several times.'')'
136 > '(''Output cannot be done between'',i10,'' et'',i10)'
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)) '
151 #ifdef _DEBUG_HOMARD_
152 write (ulsort,texte(langue,8)) ideb, ifin
156 c 2. caracteristiques du tableau
159 c 2.1. ==> recherche du nom terminal de l'objet
161 call gmnomc ( nom, nomter, codret )
163 if ( codret.eq.-3 ) then
165 elseif ( codret.eq.-1 ) then
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
175 if ( codret.eq.0 ) then
177 call gbcara ( nomter, nrotab, iadr, lgtabl, typtab )
179 if ( coergm.eq.0 ) then
181 if ( lgtabl.gt.0 ) then
184 > ( ifin.eq.0 .or. ifin.ge.lgtabl ) ) then
189 elseif ( ifin.lt.ideb ) then
192 elseif ( ideb.gt.lgtabl .or. ifin.lt.1 ) then
197 lafin = min(ifin,lgtabl)
204 elseif ( coergm.eq.1 ) then
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 "-".
224 c 3.1. ==> format des indices
226 if ( codret.eq.0 ) then
228 if ( lgtabl.gt.0 ) then
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
236 write(saux02(1:2),'(i2)') iaux+3
244 cgn print *,lafin ,' = ',saux02
250 c 3.2. ==> format des valeurs et impressions
252 if ( codret.eq.0 ) then
254 if ( nomter.eq.nom ) then
255 write (ulsort,texte(langue,9)) nomter, typtab
257 write (ulsort,texte(langue,10)) nomter, nom, typtab
259 if ( len(chaine).gt.0 ) then
260 write (ulsort,1000) chaine
263 if ( lgtabl.eq.0 ) then
264 write (ulsort,texte(langue,4)) lgtabl
269 write (ulsort,texte(langue,15)) ledebu , lafin
274 if ( typtab.eq.'entier ' ) then
277 do 312 , iaux = ledebu , lafin
278 entmax = max (entmax,abs(imem(iadr+iaux)))
279 entmin = min (entmin,imem(iadr+iaux))
282 do 322 , iaux = 9 , 1 , -1
283 if ( entmax.lt.10**iaux ) then
287 if ( entmin.ne.0 ) then
288 jaux = min(jaux+1,15)
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
295 write(fmtent(2:3),'(i2)') iaux
298 if ( jaux.le.9 ) then
299 write(fmtent(16:16),'(i1)') jaux
301 write(fmtent(16:17),'(i2)') jaux
303 write (ulsort,fmtent)
304 > (iaux,imem(iadr+iaux),iaux=ledebu,lafin)
306 elseif ( typtab.eq.'chaine ' ) then
308 iaux = max(10,(120-mod(120,iaux))/iaux)
309 write(fmtstr(2:3),'(i2)') iaux
311 write (ulsort,fmtstr)
312 > (iaux,smem(iadr+iaux),iaux=ledebu,lafin)
314 elseif ( typtab.eq.'reel ' ) then
317 write (ulsort,fmt141)
318 > (iaux,rmem(iadr+iaux),iaux=ledebu,lafin)
321 write (ulsort,fmt142)
322 > (iaux,rmem(iadr+iaux),iaux=ledebu,lafin)
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))
338 c 4. gestion des erreurs
341 if ( codret.ne.0 ) then
343 #ifdef _DEBUG_HOMARD_
345 write (ulsort,texte(langue,1)) 'Sortie', nompro
346 write (ulsort,texte(langue,2)) codret
348 write (ulsort,texte(langue,5)) nomter
350 if ( codret.eq.-6 ) then
351 write (ulsort,texte(langue,4)) lgtabl
353 if ( codret.eq.-5 .or. codret.eq.-6 ) then
354 write (ulsort,texte(langue,20)) ideb, ifin
356 iaux = 15+abs(codret)
357 write (ulsort,texte(langue,iaux))
359 #ifdef _DEBUG_HOMARD_
361 90000 format (70('='))