1 subroutine infofo ( nbfonc, nofonc,
4 > ulsort, langue, codret )
5 c ______________________________________________________________________
9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
12 c aupres des huissiers de justice Simart et Lavoir a Clamart
13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
14 c aupres des huissiers de justice
15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
17 c HOMARD est une marque deposee d'Electricite de France
23 c ______________________________________________________________________
25 c INFOrmation : FOnction
27 c ______________________________________________________________________
29 c . nom . e/s . taille . description .
30 c .____________________________________________________________________.
31 c . nbfonc . e . 1 . nombre de fonctions .
32 c . nofonc . e . nbfonc . nom des objets qui contiennent la .
33 c . . . . description de chaque fonction .
34 c . typg . e . 1 . type de l'entite a examiner .
35 c . numcal . e . 1 . numero du calcul de l'entite a examiner .
36 c . ulecr . e . 1 . unite logique pour l'ecriture .
37 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
38 c . langue . e . 1 . langue des messages .
39 c . . . . 1 : francais, 2 : anglais .
40 c . codret . es . 1 . code de retour des modules .
41 c . . . . 0 : pas de probleme .
42 c . . . . 2 : probleme dans les memoires .
43 c . . . . 3 : probleme dans les fichiers .
44 c . . . . 5 : probleme autre .
45 c ______________________________________________________________________
48 c 0. declarations et dimensionnement
51 c 0.1. ==> generalites
57 parameter ( nompro = 'INFOFO' )
78 integer ulsort, langue, codret
82 c 0.4. ==> variables locales
84 integer iaux, jaux, kaux
85 integer adaux1, adaux2, adaux3
86 integer nrfonc, nrtafo
88 integer advale, advalr, adobch, adprpg, adtyas
89 integer typgeo, ngauss, nbenmx, nbvapr, nbtyas
90 integer carsup, nbtafo, typint
92 integer nbcomp, nbtvch, typcha
93 integer nrocmp, nrotch
95 integer adnocp, adcaen, adcare, adcaca
103 character*64 nomcha, saux64, noprof
106 parameter ( nbmess = 10 )
107 character*80 texte(nblang,nbmess)
108 c ______________________________________________________________________
117 #ifdef _DEBUG_HOMARD_
118 write (ulsort,texte(langue,1)) 'Entree', nompro
122 texte(1,4) = '(''Type de l''''entite a examiner :'',i5)'
123 texte(1,5) = '(''Numero de l''''entite a examiner :'',i5)'
124 texte(1,6) = '(/,''Fonction numero '',i5)'
125 texte(1,7) = '(''. Nom du profil : '',a)'
126 texte(1,8) = '(''Incoherence dans la longueur du profil.'')'
128 texte(2,4) = '(''Type of entity :'',i5)'
129 texte(2,5) = '(''Number of entity :'',i5)'
130 texte(2,6) = '(/,''Functions # '',i5)'
131 texte(2,7) = '(''. Profil name : '',a)'
132 texte(2,8) = '(''Profile lengths are not coherent.'')'
136 #ifdef _DEBUG_HOMARD_
137 write (ulsort,texte(langue,4)) typg
138 write (ulsort,texte(langue,5)) numcal
143 c Pour eviter un message de ftnchek :
147 c 2. on parcourt toutes les fonctions
150 do 20 , nrfonc = 1 , nbfonc
152 c 2.1. ==> caracterisation de la fonction courante
154 if ( codret.eq.0 ) then
156 nnfonc = nofonc(nrfonc)
158 #ifdef _DEBUG_HOMARD_
159 write (ulsort,texte(langue,6)) nrfonc
160 cgn call gmprsx (nompro, nnfonc )
161 cgn call gmprsx (nompro, nnfonc//'.ValeursR' )
164 #ifdef _DEBUG_HOMARD_
165 write (ulsort,texte(langue,3)) 'UTCAFO', nompro
167 call utcafo ( nnfonc,
169 > typgeo, ngauss, nbenmx, nbvapr, nbtyas,
170 > carsup, nbtafo, typint,
171 > advale, advalr, adobch, adprpg, adtyas,
172 > ulsort, langue, codret )
176 #ifdef _DEBUG_HOMARD_
177 write (ulsort,90002) 'typcha', typcha
178 write (ulsort,90002) 'typgeo', typgeo
179 write (ulsort,90002) 'ngauss', ngauss
180 write (ulsort,90002) 'nbenmx', nbenmx
181 write (ulsort,90002) 'nbvapr', nbvapr
182 write (ulsort,90002) 'nbtyas', nbtyas
183 write (ulsort,90002) 'carsup', carsup
184 write (ulsort,90002) 'nbtafo', nbtafo
187 c 2.2. ==> En l'absence de profil, le numero d'entite a rechercher est
188 c le numero dans le calcul qui est fourni en argument
189 c Avec un profil, on cherche si ce numero est present dans la
190 c liste. Si oui, on memorise sa position avec numcal ; si non,
191 c on mentionne qu'aucune valeur n'est disponible.
193 if ( codret.eq.0 ) then
195 if ( nbvapr.le.0 ) then
201 saux08 = smem(adprpg)
202 #ifdef _DEBUG_HOMARD_
203 write (ulsort,texte(langue,3)) 'UTCAPR', nompro
205 call utcapr ( saux08,
206 > iaux, noprof, adlipr,
207 > ulsort, langue, codret )
209 if ( codret.eq.0 ) then
211 #ifdef _DEBUG_HOMARD_
212 write (ulsort,texte(langue,7)) noprof
213 call gmprot (nompro,saux08//'.ListEnti',1,50)
215 if ( iaux.ne.nbvapr ) then
216 write (ulsort,texte(langue,8))
217 write (ulsort,90002) 'Pour la fonction', nbvapr
218 write (ulsort,90002) 'Pour le profil ', iaux
224 if ( codret.eq.0 ) then
227 do 220 , iaux = 0 , nbvapr-1
228 if ( imem(adlipr+iaux).eq.numcal ) then
241 c 2.3. ==> les valeurs
243 if ( codret.eq.0 ) then
245 if ( typgeo.eq.typg ) then
247 cgn call gmprot (nompro, nnfonc//'.ValeursR',1,nbenmx*nbtafo )
248 if ( ngauss.eq.ednopg ) then
254 do 231 , nrtafo = 1 , nbtafo
256 c 2.3.1. ==> le nom du champ et de la composante
257 c 2.3.1.1. ==> recuperation
259 if ( codret.eq.0 ) then
261 saux08 = smem(adobch+nrtafo-1)
262 #ifdef _DEBUG_HOMARD_
263 cgn call gmprsx (nompro,saux08)
264 cgn call gmprsx (nompro,saux08//'.Nom_Comp')
265 cgn call gmprsx (nompro,saux08//'.Cham_Ent')
266 cgn call gmprsx (nompro,saux08//'.Cham_Ree')
267 call gmprsx (nompro,saux08//'.Cham_Car')
268 call gmprsx (nompro,'%%%%%%19')
269 call gmprsx (nompro,'%%%%%%19.ValeursR')
270 cgn call gmprsx (nompro,'%%%%%%19.ValeursE')
272 #ifdef _DEBUG_HOMARD_
273 write (ulsort,texte(langue,3)) 'UTCACH', nompro
275 call utcach ( saux08,
277 > nbcomp, nbtvch, typcha,
278 > adnocp, adcaen, adcare, adcaca,
279 > ulsort, langue, codret )
283 cgn write(ulsort,*) 'nbcomp = ',nbcomp , ', nbtvch = ',nbtvch
284 if ( codret.eq.0 ) then
285 cgn write(ulsort,*) 'nrtafo = ',nrtafo , ', saux64 = ',saux64
287 c 2.3.1.2. ==> le nom du champ
289 if ( nrtafo.eq.1 .or. saux64.ne.nomcha ) then
291 write (ulecr,30001) nomcha(1:48)
292 call utlgut ( iaux, nomcha, ulsort, langue, codret )
293 if ( iaux.gt.48 ) then
294 write (ulecr,30002) nomcha(49:64)
300 c 2.3.1.3. ==> le pas de temps
302 if ( nrocmp.eq.nbcomp ) then
305 if ( imem(adcaen+nbinec*(nrotch-1)+1).eq.ednodt .and.
306 > imem(adcaen+nbinec*(nrotch-1)+2).eq.ednonr ) then
309 write(ulecr,30003) imem(adcaen+nbinec*(nrotch-1)+1),
310 > imem(adcaen+nbinec*(nrotch-1)+2)
311 saux16 = smem(adnocp+8+4*nbcomp)//
312 > smem(adnocp+9+4*nbcomp)
313 if ( saux16(1:8).eq.'INCONNUE' ) then
316 write(ulecr,30005) rmem(adcare+nrotch-1), saux16
320 c 2.3.1.4. ==> le nom et l'unite de la composante
323 nomcmp = smem(adnocp+6+2*nrocmp)//smem(adnocp+7+2*nrocmp)
324 saux16 = smem(adnocp+6+2*nbcomp+2*nrocmp)//
325 > smem(adnocp+7+2*nbcomp+2*nrocmp)
327 if ( saux16.eq.blan16 ) then
330 unicmp = '('//saux16//')'
335 c 2.3.2. ==> la/les valeurs
337 #ifdef _DEBUG_HOMARD_
338 write (ulsort,90002) 'nument', nument
341 if ( nument.eq.0 ) then
343 if ( nrocmp.eq.nbcomp ) then
349 if ( typcha.eq.edfl64 ) then
354 adaux1 = adaux1 + nbtafo*nbpg*(nument-1)-1
356 if ( nomcmp.ne.blan16 ) then
357 write (ulecr,30006) nomcmp, unicmp
359 if ( nbcomp.gt.1 ) then
360 write (ulecr,30016) nrocmp
363 adaux2 = adaux1 + nrtafo
365 if ( nbpg.eq.1 ) then
367 if ( typcha.eq.edfl64 ) then
368 write (ulecr,30105) rmem(adaux2)
370 write (ulecr,30205) imem(adaux2)
374 cgn call gmprot (nompro, nnfonc//'.ValeursR',1,nbenmx*nbtafo*nbpg )
375 kaux = nbpg - mod(nbpg,2)
376 do 232 , jaux = 1 , kaux, 2
377 adaux3 = adaux2 + nbtafo*jaux
378 if ( carsup.eq.1 ) then
379 if ( typcha.eq.edfl64 ) then
380 write (ulecr,30106) jaux, rmem(adaux3-nbtafo),
381 > jaux+1, rmem(adaux3)
383 write (ulecr,30206) jaux, imem(adaux3-nbtafo),
384 > jaux+1, imem(adaux3)
387 if ( typcha.eq.edfl64 ) then
388 write (ulecr,30108) jaux, rmem(adaux3-nbtafo),
389 > jaux+1, rmem(adaux3)
391 write (ulecr,30208) jaux, imem(adaux3-nbtafo),
392 > jaux+1, imem(adaux3)
397 if ( mod(nbpg,2).ne.0 ) then
398 adaux3 = adaux2 + nbtafo*(nbpg-1)
399 if ( typcha.eq.edfl64 ) then
400 if ( carsup.eq.1 ) then
401 write (ulecr,30107) nbpg, rmem(adaux3)
403 write (ulecr,30109) nbpg, rmem(adaux3)
406 if ( carsup.eq.1 ) then
407 write (ulecr,30207) nbpg, imem(adaux3)
409 write (ulecr,30209) nbpg, imem(adaux3)
431 > '* Champ : ',a48, ' *')
435 > '* Pas de temps :',i10, ', Numero d''ordre :',i10, ' ',
438 > '* Sans pas de temps, ni numero d''ordre ',
441 > '* Instant :', d14.7, ' ',a16, ' *')
443 > '* . Composante : ',a16, ' ',a18, ' *')
445 > '* . Composante numero',i3,
448 > '* ', d14.7, 42x, '*')
449 c 12345678901234123456789012345678901234567890123456789012
451 > '* ',2('no ',i2,' : ', d15.8,4x), ' *')
453 > '* ','no ',i2,' : ', d15.8,33x,'*')
455 > '* ',2('pg ',i2,' : ', d15.8,4x), ' *')
457 > '* ','pg ',i2,' : ', d15.8,33x,'*')
459 > '* ', i14, 42x, '*')
461 > '* ',2('no ',i2,' : ', i15,4x), ' *')
463 > '* ','no ',i2,' : ', i15,33x,'*')
465 > '* ',2('pg ',i2,' : ', i15,4x), ' *')
467 > '* ','pg ',i2,' : ', i15,33x,'*')
469 > '* Aucune valeur n''est presente. ',
476 if ( codret.ne.0 ) then
480 write (ulsort,texte(langue,1)) 'Sortie', nompro
481 write (ulsort,texte(langue,2)) codret
485 #ifdef _DEBUG_HOMARD_
486 write (ulsort,texte(langue,1)) 'Sortie', nompro