1 subroutine sfgrf2 ( nbfmed,
2 > nbf, nbgrmx, nblign, lgtabl,
3 > pointl, taigrl, nomgrl,
4 > pointf, nomgrf, numfam,
6 > ulsort, langue, codret )
7 c ______________________________________________________________________
11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
13 c Version originale enregistree le 18 juin 1996 sous le numero 96036
14 c aupres des huissiers de justice Simart et Lavoir a Clamart
15 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
16 c aupres des huissiers de justice
17 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
19 c HOMARD est une marque deposee d'Electricite de France
25 c ______________________________________________________________________
27 c Suivi de Frontiere - GRoupes de la Frontiere - phase 2
29 c remarque : sfgrf2 et sfgrf3 sont des clones
30 c Creation de la liste des groupes de segments du maillage frontiere
31 c ______________________________________________________________________
33 c . nom . e/s . taille . description .
34 c .____________________________________________________________________.
35 c . nbfmed . e . 1 . nombre de familles de mailles de frontiere .
36 c . nbf . e . 1 . nombre de familles du maillage frontiere .
37 c . nbgrmx . e . 1 . nombre maxi de groupes dans les familles .
38 c . nblign . s . 1 . nombre de lignes decrites .
39 c . lgtabl . s . 1 . longueur des tables .
40 c . pointl . s .0:nbgrmx. pointeur sur le tableau nomgrl .
41 c . taigrl . s . * . taille des noms des groupes des lignes .
42 c . nomgrl . s . * . noms des groupes des lignes .
43 c . pointf . e . 0:nbf . pointeur sur le tableau nomgrf .
44 c . numfam . e . nbf . numero des familles au sens MED .
45 c . nomgrf . e . * . noms des groupes des familles .
46 c . lifami . e . nbfmed . liste des familles a explorer .
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 . . . . 1 : probleme .
53 c ______________________________________________________________________
56 c 0. declarations et dimensionnement
59 c 0.1. ==> generalites
65 parameter ( nompro = 'SFGRF2' )
77 integer nbf, nbgrmx, nblign, lgtabl
78 integer lifami(nbfmed)
79 integer pointl(0:nbgrmx), pointf(0:nbf), numfam(nbf)
82 character*8 nomgrl(*), nomgrf(*)
84 integer ulsort, langue, codret
86 c 0.4. ==> variables locales
88 integer iaux, jaux, kaux, lig, fam
90 integer lgngrl, lgngrf
92 character*80 groupl,groupf
95 parameter ( nbmess = 10 )
96 character*80 texte(nblang,nbmess)
98 c 0.5. ==> initialisations
99 c ______________________________________________________________________
107 #ifdef _DEBUG_HOMARD_
108 write (ulsort,texte(langue,1)) 'Entree', nompro
112 texte(1,4) = '(''Nombre de familles de '',a,'' :'',i8)'
113 texte(1,5) = '(/,''Ligne numero '',i5,/,18(''=''))'
114 texte(1,6) = '(''. Elle est definie par le groupe : '',a,/)'
116 texte(2,4) = '(''Number of families of '',a,'' :'',i8)'
117 texte(2,5) = '(/,''Line # '',i5,/,12(''=''))'
118 texte(2,6) = '(''. It is defined by group : '',a,/)'
126 #ifdef _DEBUG_HOMARD_
127 write (ulsort,texte(langue,4)) mess14(langue,3,1), nbfmed
131 c 2. on parcourt toutes les familles de mailles du maillage frontiere
132 c pour enregistrer les groupes du maillage frontiere
135 cgn write (ulsort,93080) (nomgrf(iaux),iaux=1,20)
138 if ( codret.eq.0 ) then
140 #ifdef _DEBUG_HOMARD_
141 write (ulsort,90015) 'Famille ', fam, ', de numero', numfam(fam)
144 c 2.1. ==> la famille est-elle a traiter ?
146 do 21 , iaux = 1, nbfmed
148 cgn write (ulsort,90112) 'lifami', iaux, lifami(iaux)
149 if ( numfam(fam).eq.lifami(iaux) ) then
157 c 2.2. ==> on parcourt tous les groupes entrant dans la
158 c definition de cette famille
162 nbgr = (pointf(fam)-pointf(fam-1))/10
166 c 2.2.1. ==> nom du groupe associe
167 c adresse du debut du groupe numero gr de la famille fam
169 if ( codret.eq.0 ) then
171 iaux = pointf(fam-1)+1+10*(gr-1)
173 c recuperation du nom du groupe numero gr dans la famille
175 call uts8ch ( nomgrf(iaux), 80, groupf,
176 > ulsort, langue, codret )
180 if ( codret.eq.0 ) then
182 c longueur utile du nom du groupe
183 call utlgut ( lgngrf, groupf, ulsort, langue, codret )
187 #ifdef _DEBUG_HOMARD_
188 write (ulsort,*) '.. groupf = ', groupf
189 write (ulsort,*) '.. lgngrf = ', lgngrf
192 c 2.2.2. ==> on cherche si le groupe est deja present dans la liste
194 do 222 , lig = 1 , nblign
196 if ( codret.eq.0 ) then
197 c adresse du debut du groupe associe a la ligne lig
198 iaux = pointl(lig-1) + 1
200 c recuperation du nom du groupe associe a la ligne lig
201 call uts8ch ( nomgrl(iaux), 80, groupl,
202 > ulsort, langue, codret )
206 if ( codret.eq.0 ) then
208 c longueur utile du nom du groupe
209 call utlgut ( lgngrl, groupl, ulsort, langue, codret )
213 c ......... si le groupe de la ligne et le groupe dans la liste
214 c ......... coincident, on passe au groupe suivant dans la famille
216 if ( lgngrl.eq.lgngrf ) then
218 if ( groupl(1:lgngrl).eq.groupf(1:lgngrf) ) then
226 c 2.2.3. ==> le groupe est absent de la liste ; on allonge la liste
230 #ifdef _DEBUG_HOMARD_
231 write (ulsort,texte(langue,5)) nblign
232 write (ulsort,texte(langue,6)) groupf(1:lgngrf)
235 iaux = pointl(nblign-1) + 1
237 call utchs8 ( groupf, lgngrf, nomgrl(iaux),
238 > ulsort, langue, codret )
240 kaux = (lgngrf-mod(lgngrf,8)) / 8
241 do 223 , jaux = 1 , kaux
242 taigrl(iaux+jaux-1) = 8
245 if ( mod(lgngrf,8).ne.0 ) then
246 taigrl(iaux+kaux) = mod(lgngrf,8)
250 pointl(nblign) = pointl(nblign-1) + kaux
259 #ifdef _DEBUG_HOMARD_
267 if ( codret.ne.0 ) then
271 write (ulsort,texte(langue,1)) 'Sortie', nompro
272 write (ulsort,texte(langue,2)) codret
276 #ifdef _DEBUG_HOMARD_
277 write (ulsort,texte(langue,1)) 'Sortie', nompro