1 subroutine esecf0 ( idfmed, nomamd,
2 > typenh, nbfent, numfam, nhenti,
4 > ulsort, langue, codret)
6 c ______________________________________________________________________
10 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
12 c Version originale enregistree le 18 juin 1996 sous le numero 96036
13 c aupres des huissiers de justice Simart et Lavoir a Clamart
14 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
15 c aupres des huissiers de justice
16 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
18 c HOMARD est une marque deposee d'Electricite de France
24 c ______________________________________________________________________
26 c Entree-Sortie : ECriture des Familles d'une entite - 0
28 c ______________________________________________________________________
29 c . nom . e/s . taille . description .
30 c .____________________________________________________________________.
31 c . idfmed . e . 1 . identificateur du fichier MED .
32 c . nomamd . e . char64 . nom du maillage MED voulu .
33 c . typenh . e . 1 . code des entites .
34 c . . . . -1 : noeuds .
35 c . . . . 0 : mailles-points .
36 c . . . . 1 : aretes .
37 c . . . . 2 : triangles .
38 c . . . . 3 : tetraedres .
39 c . . . . 4 : quadrangles .
40 c . . . . 5 : pyramides .
41 c . . . . 6 : hexaedres .
42 c . . . . 7 : pentaedres .
43 c . nbfent . e . 1 . nombre de familles d'entites (cf. nbfami) .
44 c . numfam . es . 1 . numerotation des familles .
45 c . nhenti . e . char*8 . objet decrivant l'entite .
46 c . tbiaux . . * . tableau tampon entier .
47 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
48 c . langue . e . 1 . langue des messages .
49 c . . . . 1 : francais, 2 : anglais .
50 c . codret . es . 1 . code de retour des modules .
51 c . . . . 0 : pas de probleme .
52 c ______________________________________________________________________
55 c 0. declarations et dimensionnement
58 c 0.1. ==> generalites
64 parameter ( nompro = 'ESECF0' )
81 integer typenh, nbfent, numfam
87 integer ulsort, langue, codret
89 c 0.4. ==> variables locales
94 parameter (nbgrox = 10 )
96 integer iaux, jaux, kaux, laux
97 integer cptr, kfin, reste
104 character*80 nomgro(nbgrox)
108 parameter ( nbmess = 150 )
109 character*80 texte(nblang,nbmess)
110 c ______________________________________________________________________
118 #ifdef _DEBUG_HOMARD_
119 write (ulsort,texte(langue,1)) 'Entree', nompro
123 texte(1,4) = '(''. Ecriture des'',i4,'' familles des '',a)'
124 texte(1,5) = '(''... Ecriture de la'',i4,''-ieme famille'')'
125 texte(1,6) = '(''Probleme de dimensionnement de nomgro.'')'
127 texte(2,4) = '(''. Writings of'',i4,'' families for '',a)'
128 texte(2,5) = '(''... Writings of the'',i4,''-th family'')'
129 texte(2,6) = '(''Error in size of array nomgro.'')'
135 #ifdef _DEBUG_HOMARD_
136 write (ulsort,texte(langue,4)) nbfent, mess14(langue,3,typenh)
137 call gmprsx ( nompro, nhenti//'.Famille' )
138 call gmprsx ( nompro, nhenti//'.Famille.Codes' )
139 cc call gmprsx ( nompro, nhenti//'.Famille.Groupe' )
143 c 2. Gestion de la memoire
145 c 2.1. ==> Determination des adresses
146 c 2.1.1. ==> pour les noeuds
148 if ( typenh.lt.0 ) then
150 #ifdef _DEBUG_HOMARD_
151 write (ulsort,texte(langue,3)) 'UTAD01', nompro
154 call utad01 ( iaux, nhenti,
156 > jaux, adcofa, jaux,
157 > jaux, jaux, jaux, jaux,
158 > ulsort, langue, codret )
160 c 2.1.2. ==> pour les mailles
164 #ifdef _DEBUG_HOMARD_
165 write (ulsort,texte(langue,3)) 'UTAD02', nompro
168 call utad02 ( iaux, nhenti,
169 > jaux, jaux, jaux, jaux,
170 > jaux, adcofa, jaux,
173 > ulsort, langue, codret )
177 c 2.2. ==> Nombre de codes definissant les familles
179 if ( codret.eq.0 ) then
181 call gmliat ( nhenti//'.Famille', 2, nbcode, codre1 )
183 codret = max ( codret,
186 #ifdef _DEBUG_HOMARD_
187 write(ulsort,90002) 'nbcode', nbcode
195 #ifdef _DEBUG_HOMARD_
196 write (ulsort,*) '3. Ecritures ; codret = ', codret
199 if ( codret.eq.0 ) then
202 do 31 , iaux = 1 , nbfent
204 #ifdef _DEBUG_HOMARD_
205 write (ulsort,texte(langue,5)) iaux
206 call gmprsx ( nompro, nhenti//'.Famille.Codes' )
209 if ( codret.eq.0 ) then
211 c fabrication du numero de la famille a ecrire
213 if ( typenh.lt.0 ) then
219 c fabrication du nom de la famille a ecrire
221 call utench ( numfam, '_', jaux, saux08,
222 > ulsort, langue, codret )
225 saux64(1:2) = suffix(3,typenh)(1:2)
226 saux64( 3:10) = saux08
228 c les valeurs entieres a memoriser
229 c . le numero de la famille
232 c . les nctfen codes definissant les familles
233 do 311 , jaux = 1, nbcode
234 tbiaux(jaux+1) = imem(adcoen+jaux)
236 adcoen = adcoen + nbcode
240 c fabrication d'un nom de groupe contenant ces valeurs
241 c . Les 8 1ers caracteres sont 'Attribut' obligatoirement, pour
242 c se reperer dans le dump
243 c . Les caracteres de 2 a nbcode+1 sont les nbcode codes
244 c convertis en chaine
245 c Remarque : cela suppose qu'il n'y a pas plus de 9 codes
246 c et que chaque code est inferieur a 10**8
250 if ( codret.eq.0 ) then
252 reste = mod(nbcode+1,9)
253 ngro = (nbcode+1-reste)/9
254 if ( reste.gt.0 ) then
257 if ( ngro.gt.nbgrox ) then
260 cgn write(ulsort,*) 'Famille : ', saux64
261 cgn write(ulsort,90002) 'nbcode ', nbcode
262 cgn write(ulsort,90002) 'reste ', reste
263 cgn write(ulsort,90002) 'ngro ', ngro
267 if ( codret.eq.0 ) then
270 do 312 , jaux = 1, ngro
272 nomgro(jaux) = blan80
274 nomgro(jaux)(1:8) = 'Attribut'
275 if ( jaux.lt.ngro .or. reste.eq.0 ) then
280 do 3121 , kaux = 1, kfin
282 call utench ( tbiaux(cptr), 'd', laux, saux08,
283 > ulsort, langue, codret )
284 nomgro(jaux)(8*kaux+1:8*(kaux+1)) = saux08
290 if ( codret.eq.0 ) then
292 #ifdef _DEBUG_HOMARD_
293 write(ulsort,*) 'Famille : ', saux64
294 write(ulsort,90002) 'nbcode', nbcode
295 if ( nbcode.gt.0 ) then
296 write(ulsort,90002) '.', (tbiaux(jaux),jaux=1,nbcode+1)
298 write(ulsort,90002) 'ngro', ngro
299 write(ulsort,*) nomgro
302 #ifdef _DEBUG_HOMARD_
303 write (ulsort,texte(langue,3)) 'MFACRE', nompro
305 call mfacre ( idfmed, nomamd, saux64, numfam,
306 > ngro, nomgro, codret )
308 if ( codret.ne.0 ) then
309 write(ulsort,texte(langue,78)) 'mfacre', codret
322 if ( codret.ne.0 ) then
326 write (ulsort,texte(langue,1)) 'Sortie', nompro
327 write (ulsort,texte(langue,2)) codret
328 if ( codret.eq.31 ) then
329 write(ulsort,90002) 'ngro ', ngro
330 write(ulsort,90002) 'nbgrox', nbgrox
331 write (ulsort,texte(langue,6))
336 #ifdef _DEBUG_HOMARD_
337 write (ulsort,texte(langue,1)) 'Sortie', nompro