1 subroutine eslefe ( idfmed, nomamd,
2 > nhnoeu, nhmapo, nharet, nhtria, nhquad,
3 > nhtetr, nhhexa, nhpyra, nhpent,
6 > ulsort, langue, codret)
8 c ______________________________________________________________________
12 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
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
20 c HOMARD est une marque deposee d'Electricite de France
26 c ______________________________________________________________________
28 c Entree-Sortie : LEcture des Familles des Entites
30 c ______________________________________________________________________
31 c . nom . e/s . taille . description .
32 c .____________________________________________________________________.
33 c . idfmed . e . 1 . identificateur du fichier MED .
34 c . nomamd . e . char64 . nom du maillage MED voulu .
35 c . nhsups . e . char*8 . informations supplementaires caracteres 8 .
36 c . ltbsau . e . 1 . longueur allouee a tbsaux .
37 c . tbsaux . . * . tableau tampon caracteres .
38 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
39 c . langue . e . 1 . langue des messages .
40 c . . . . 1 : francais, 2 : anglais .
41 c . codret . es . 1 . code de retour des modules .
42 c . . . . 0 : pas de probleme .
43 c ______________________________________________________________________
46 c 0. declarations et dimensionnement
49 c 0.1. ==> generalites
55 parameter ( nompro = 'ESLEFE' )
79 character*8 tbsaux(ltbsau)
80 character*8 nhnoeu, nhmapo, nharet, nhtria, nhquad
82 character*8 nhtetr, nhhexa, nhpyra, nhpent
85 integer ulsort, langue, codret
87 c 0.4. ==> variables locales
92 parameter (nbgrox = 10000 )
94 integer iaux, jaux, kaux
95 integer cptr, kdeb, kfin, reste
97 integer nbfmed, nrofam, numfam, natt, ngro
100 integer codre1, codre2
101 integer adcono, adcomp, adcoar, adcotr, adcoqu
102 integer adcote, adcopy, adcohe, adcope
104 integer adnogr, lgnogr
105 integer numtab, numgro
114 parameter ( nbmess = 150 )
115 character*80 texte(nblang,nbmess)
116 c ______________________________________________________________________
125 #ifdef _DEBUG_HOMARD_
126 write (ulsort,texte(langue,1)) 'Entree', nompro
132 texte(1,4) = '(''. Lecture des familles'')'
133 texte(1,6) = '(''Allongement de nomgro.'')'
134 texte(1,81) = '(''Longueur allouee pour tbsaux : '',i10)'
135 texte(1,82) = '(''Longueur necessaire pour tbsaux : '',i10)'
137 texte(2,4) = '(''. Readings of families'')'
138 texte(2,6) = '(''Extension of nomgro.'')'
139 texte(2,81) = '(''Allocated length for tbsaux : '',i10)'
140 texte(2,82) = '(''Used length for tbsaux : '',i10)'
144 1002 format(10(a8,'+'))
147 #ifdef _DEBUG_HOMARD_
148 write (ulsort,texte(langue,4))
156 #ifdef _DEBUG_HOMARD_
157 write (ulsort,90002) '2. Preparatifs ; codret', codret
160 do 21 , typenh = -1 , 7
162 if ( codret.eq.0 ) then
164 if ( typenh.eq.-1 ) then
167 elseif ( typenh.eq.0 ) then
170 elseif ( typenh.eq.1 ) then
173 elseif ( typenh.eq.2 ) then
176 elseif ( typenh.eq.3 ) then
179 elseif ( typenh.eq.4 ) then
182 elseif ( typenh.eq.5 ) then
185 elseif ( typenh.eq.6 ) then
193 if ( iaux.gt.0 ) then
195 #ifdef _DEBUG_HOMARD_
197 write (ulsort,*) mess14(langue,4,typenh)
198 write (ulsort,90002) 'nbfent', iaux
201 call gmadoj ( nhenti//'.Famille.Codes', adcoen, iaux, codre1 )
203 codret = max ( codret,
210 if ( codret.eq.0 ) then
212 if ( typenh.eq.-1 ) then
214 elseif ( typenh.eq.0 ) then
216 elseif ( typenh.eq.1 ) then
218 elseif ( typenh.eq.2 ) then
220 elseif ( typenh.eq.3 ) then
222 elseif ( typenh.eq.4 ) then
224 elseif ( typenh.eq.5 ) then
226 elseif ( typenh.eq.6 ) then
236 ccc write (ulsort,90002) 'adcono', adcono
237 ccc write (ulsort,90002) 'adcomp', adcomp
238 ccc write (ulsort,90002) 'adcoar', adcoar
239 ccc write (ulsort,90002) 'adcotr', adcotr
240 ccc write (ulsort,90002) 'adcote', adcote
241 ccc write (ulsort,90002) 'adcoqu', adcoqu
242 ccc write (ulsort,90002) 'adcopy', adcopy
243 ccc write (ulsort,90002) 'adcohe', adcohe
244 ccc write (ulsort,90002) 'adcope', adcope
246 c 3. Nombre de familles dans le fichier
248 #ifdef _DEBUG_HOMARD_
249 write (ulsort,90002) '3. Nombre de familles ; codret', codret
252 if ( codret.eq.0 ) then
254 #ifdef _DEBUG_HOMARD_
255 write (ulsort,texte(langue,3)) 'MFANFA', nompro
257 call mfanfa ( idfmed, nomamd, nbfmed, codret )
259 #ifdef _DEBUG_HOMARD_
260 write (ulsort,texte(langue,29)) nbfmed
266 c 4. Lecture des familles MED decrivant les familles HOMARD
268 #ifdef _DEBUG_HOMARD_
269 write (ulsort,90002) '4. Lecture des familles ; codret', codret
272 c 4.0. ==> Allocation d'un tableau tampon pour les noms des groupes
274 if ( codret.eq.0 ) then
277 call gmalot ( ntnogr , 'chaine ', lgnogr, adnogr, codret )
278 #ifdef _DEBUG_HOMARD_
279 write(ulsort,90002) 'lgnogr', lgnogr
284 do 40 , nrofam = 1 , nbfmed
285 #ifdef _DEBUG_HOMARD_
286 write (ulsort,90002) 'nrofam', nrofam
289 c 4.1. ==> Caracterisations de la famille en cours de lecture
291 if ( codret.eq.0 ) then
293 #ifdef _DEBUG_HOMARD_
294 write (ulsort,texte(langue,3)) 'MFANFG', nompro
297 call mfanfg ( idfmed, nomamd, iaux, ngro, codret )
300 #ifdef _DEBUG_HOMARD_
301 write(ulsort,90002) 'ngro ', ngro
304 c 4.2. ==> Ici, on decode les familles HOMARD
305 c ATTENTION : le test est severe mais il faudrait
306 c avoir une fonction qui ne renvoie que le nom de la famille,
307 c sans retourner nomgro
309 if ( codret.eq.0 ) then
311 if ( ngro.gt.nbgrox ) then
312 #ifdef _DEBUG_HOMARD_
313 write(ulsort,90002) 'lgnogr', lgnogr
314 write(ulsort,90002) 'ngro ', ngro
315 write (ulsort,texte(langue,6))
318 call gmmod ( ntnogr, adnogr, lgnogr, iaux, 1, 1, codret )
320 #ifdef _DEBUG_HOMARD_
321 write(ulsort,90002) 'lgnogr', lgnogr
328 c 4.3. ==> Lecture du contenu de la famille
330 if ( codret.eq.0 ) then
332 #ifdef _DEBUG_HOMARD_
333 write (ulsort,texte(langue,3)) 'MFAFAI', nompro
336 call mfafai ( idfmed, nomamd, iaux, nomfam, numfam,
337 > smem(adnogr), codret )
340 #ifdef _DEBUG_HOMARD_
341 write (ulsort,*) '... Famille ', nomfam
342 write (ulsort,90002) 'numfam', numfam
343 write (ulsort,*) (smem(adnogr+iaux),iaux=0,ngro-1)
344 call gmprot(nompro, ntnogr, 1, 41 )
349 if ( codret.eq.0 ) then
351 do 45 , typenh = -1 , 7
353 if ( nomfam(1:2).eq.suffix(3,typenh)(1:2) ) then
355 #ifdef _DEBUG_HOMARD_
356 write (ulsort,*) '... Famille ', nomfam
357 write (ulsort,90002) 'numfam', numfam
360 c 4.5.1. ==> le numero de la famille HOMARD
361 c Attention : le numero de la famille HOMARD associee est
362 c le 1er attribut (cf. esecf0). Il faut gerer le decalage
363 c des codes en consequence
365 if ( codret.eq.0 ) then
367 #ifdef _DEBUG_HOMARD_
368 write (ulsort,texte(langue,3)) 'UTS8CH', nompro
371 call uts8ch ( smem(adnogr), iaux, nomgro,
372 > ulsort, langue, codret )
373 #ifdef _DEBUG_HOMARD_
374 write (ulsort,*) '... nomgro : ', nomgro
379 if ( codret.eq.0 ) then
381 #ifdef _DEBUG_HOMARD_
382 write (ulsort,texte(langue,3)) 'UTCHEN', nompro//"-4.5.1."
384 call utchen ( nomgro(9:16), kaux,
385 > ulsort, langue, codret )
386 #ifdef _DEBUG_HOMARD_
387 write (ulsort,90002) 'Numero famille HOMARD', kaux
391 c 4.5.2. ==> les codes
393 if ( typenh.eq.-1 ) then
395 adcoen = adcono + kaux*nctfno
396 elseif ( typenh.eq.0 ) then
398 adcoen = adcomp + kaux*nctfmp
399 elseif ( typenh.eq.1 ) then
401 adcoen = adcoar + kaux*nctfar
402 elseif ( typenh.eq.2 ) then
404 adcoen = adcotr + kaux*nctftr
405 elseif ( typenh.eq.3 ) then
407 adcoen = adcote + kaux*nctfte
408 elseif ( typenh.eq.4 ) then
410 adcoen = adcoqu + kaux*nctfqu
411 elseif ( typenh.eq.5 ) then
413 adcoen = adcopy + kaux*nctfpy
414 elseif ( typenh.eq.6 ) then
416 adcoen = adcohe + kaux*nctfhe
419 adcoen = adcope + kaux*nctfpe
421 #ifdef _DEBUG_HOMARD_
422 write (ulsort,90002) 'natt', natt
425 reste = mod(natt+1,9)
426 #ifdef _DEBUG_HOMARD_
427 write (ulsort,90002) 'reste', reste
432 do 451 , jaux = 1, ngro
433 if ( jaux.lt.ngro .or. reste.eq.0 ) then
439 call uts8ch ( smem(adnogr+10*(jaux-1)), iaux, nomgro,
440 > ulsort, langue, codret )
441 do 4511 , iaux = kdeb, kfin
442 #ifdef _DEBUG_HOMARD_
443 write (ulsort,texte(langue,3)) 'UTCHEN', nompro//"-do 4511"
445 call utchen ( nomgro(8*iaux+1:8*(iaux+1)), kaux,
446 > ulsort, langue, codret )
462 ccc call gmprsx ( nompro, nhnoeu//'.Famille' )
463 ccc call gmprsx ( nompro, nhnoeu//'.Famille.Codes' )
464 ccc call gmprsx ( nompro, nhnoeu//'.Famille.Groupe' )
465 ccc call gmprsx ( nompro, nharet//'.Famille' )
466 ccc call gmprsx ( nompro, nharet//'.Famille.Codes' )
469 c 5. Lecture des familles de sauvegarde
471 #ifdef _DEBUG_HOMARD_
472 write (ulsort,90002) '5. Lecture familles sauv. ; codret', codret
475 do 50 , nrofam = 1 , nbfmed
476 #ifdef _DEBUG_HOMARD_
477 write (ulsort,90002) 'nrofam', nrofam
480 c 5.1. ==> Caracterisations de la famille en cours de lecture
482 if ( codret.eq.0 ) then
484 #ifdef _DEBUG_HOMARD_
485 write (ulsort,texte(langue,3)) 'MFANFG', nompro
488 call mfanfg ( idfmed, nomamd, iaux, ngro, codret )
494 if ( codret.eq.0 ) then
496 if ( 10*ngro.gt.ltbsau ) then
497 write (ulsort,texte(langue,81)) ltbsau
498 write (ulsort,texte(langue,82)) 10*ngro
504 c 5.3. ==> Lecture du contenu de la famille
506 if ( codret.eq.0 ) then
508 #ifdef _DEBUG_HOMARD_
509 write (ulsort,texte(langue,3)) 'MFAFAI', nompro
512 call mfafai ( idfmed, nomamd, iaux, nomfam, numfam,
516 #ifdef _DEBUG_HOMARD_
517 write (ulsort,*) '... Famille ', nomfam
518 write (ulsort,90002) 'numfam', numfam
519 do 5353 , jaux = 1 , ngro
520 write (ulsort,1002) (tbsaux(kaux),kaux=10*(jaux-1)+1,10*jaux)
526 if ( codret.eq.0 ) then
528 c 5.3.1. ==> La date et le titre
530 if ( nomfam(1:13).eq.'date_et_titre' ) then
532 if ( codret.eq.0 ) then
535 call uts8ch ( tbsaux, iaux, ladate,
536 > ulsort, langue, codret )
539 if ( codret.eq.0 ) then
542 call uts8ch ( tbsaux(11), iaux, titre,
543 > ulsort, langue, codret )
549 c 5.3.2. ==> Les informations supplementaires (cf. esecfs)
551 elseif ( nomfam(1:12).eq.'InfoSupS_Tab' ) then
552 #ifdef _DEBUG_HOMARD_
553 write (ulsort,*) '... Famille ', nomfam
554 write (ulsort,90002) 'numfam', numfam
555 write (ulsort,90002) 'ngro', ngro
556 do 53299 , jaux = 1 , ngro
557 write (ulsort,1002) (tbsaux(kaux),kaux=10*(jaux-1)+1,10*jaux)
563 if ( codret.eq.0 ) then
565 #ifdef _DEBUG_HOMARD_
566 write (ulsort,texte(langue,3)) 'UTCHEN', nompro//"-5.3.2.a"
568 call utchen ( nomfam(13:64), numtab,
569 > ulsort, langue, codret )
573 if ( codret.eq.0 ) then
575 c Le nombre de valeurs
577 do 5321 , jaux = 1 , ngro
579 kaux = 10*(jaux-1) + 1
580 #ifdef _DEBUG_HOMARD_
581 write (ulsort,90002) 'kaux', kaux
582 write (ulsort,*) 'tbsaux(kaux)', tbsaux(kaux)
584 if ( tbsaux(kaux).eq.'Nombre d' ) then
589 > tbsaux(kaux+3)//tbsaux(kaux+4)//tbsaux(kaux+5)//tbsaux(kaux+6)
590 #ifdef _DEBUG_HOMARD_
591 write (ulsort,texte(langue,3)) 'UTCHEN', nompro//"-5.3.2.b"
593 call utchen ( saux32, nbval, ulsort, langue, codret )
594 #ifdef _DEBUG_HOMARD_
595 write (ulsort,90002) 'nbval ', nbval
596 write (ulsort,90002) 'numgro', numgro
610 if ( codret.eq.0 ) then
612 call utlgut ( jaux, nomfam,
613 > ulsort, langue, codret )
614 call gmaloj ( nhsups//'.'//nomfam(10:jaux) , ' ',
615 > nbval, adress, codre1 )
616 call gmecat ( nhsups , numtab, nbval, codre2 )
618 codre0 = min ( codre1, codre2 )
619 codret = max ( abs(codre0), codret,
625 c il faut supprimer le pseudo-groupe du nombre de valeurs
627 if ( codret.eq.0 ) then
629 do 5322 , jaux = 1 , ngro
630 if ( jaux.ne.numgro ) then
632 do 53221 , iaux = 1, 10
633 smem(adress) = tbsaux(kaux+iaux)
638 c do 5322 , jaux = 0 , nbval-1
639 c smem(adress+jaux) = tbsaux(11+jaux)
653 #ifdef _DEBUG_HOMARD_
654 write (ulsort,90002) '6. Menage ; codret', codret
657 if ( codret.eq.0 ) then
659 call gmlboj ( ntnogr , codret )
667 if ( codret.ne.0 ) then
671 write (ulsort,texte(langue,1)) 'Sortie', nompro
672 write (ulsort,texte(langue,2)) codret
676 #ifdef _DEBUG_HOMARD_
677 write (ulsort,texte(langue,1)) 'Sortie', nompro