1 subroutine sfgrf3 ( nbfseg,
2 > nbf, nbgrmx, nblign, lgtabl,
3 > pointl, taigrl, nomgrl,
4 > pointf, nomgrf, numfam,
5 > lifami, linugr, ncafdg,
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 3
29 c remarque : sfgrf2 et sfgrf3 sont des clones
30 c Mise a jour de la liste des groupes de segments voulus
31 c ______________________________________________________________________
33 c . nom . e/s . taille . description .
34 c .____________________________________________________________________.
35 c . nbfseg . e . 1 . nombre de familles de segments .
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 . es . 1 . nombre de lignes decrites .
39 c . lgtabl . es . 1 . longueur des tables .
40 c . pointl . e .0:nblign. pointeur sur le tableau nomgrl .
41 c . taigrl . e . * . taille des noms des groupes des lignes .
42 c . nomgrl . e . * . 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 . nbfseg . liste des familles a explorer .
47 c . linugr . s . nblign . numeros des groupes acceptables .
48 c . ncafdg . es . char*8 . nom de l'objet groupes/attributs frontiere .
49 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
50 c . langue . e . 1 . langue des messages .
51 c . . . . 1 : francais, 2 : anglais .
52 c . codret . es . 1 . code de retour des modules .
53 c . . . . 0 : pas de probleme .
54 c . . . . 1 : probleme .
55 c ______________________________________________________________________
58 c 0. declarations et dimensionnement
61 c 0.1. ==> generalites
67 parameter ( nompro = 'SFGRF3' )
81 integer nbf, nbgrmx, nblign, lgtabl
82 integer pointl(0:nbgrmx), pointf(0:nbf), numfam(nbf)
84 integer lifami(nbfseg), linugr(nblign)
86 character*8 nomgrl(*), nomgrf(*)
89 integer ulsort, langue, codret
91 c 0.4. ==> variables locales
93 integer iaux, jaux, kaux, lig, fam
95 integer lgngrl, lgngrf
96 integer nblnew, lgtnew
97 integer pointn, pttgrn, ptngrn
99 character*80 groupl,groupf
103 parameter ( nbmess = 10 )
104 character*80 texte(nblang,nbmess)
106 c 0.5. ==> initialisations
107 c ______________________________________________________________________
115 #ifdef _DEBUG_HOMARD_
116 write (ulsort,texte(langue,1)) 'Entree', nompro
120 texte(1,4) = '(''Nombre de familles de '',a,'' :'',i8)'
122 >'(''*'',20x,''Elimination de groupe(s) frontiere discrete'',
125 >'(''*'',20x,''Tous les groupes sont elimines'',32x,''*'')'
127 texte(2,4) = '(''Number of families of '',a,'' :'',i8)'
129 >'(''*'',20x,''Elimination of discrete boundary group(s)'',
132 >'(''*'',20x,''All the groups are taken off'',34x,''*'')'
138 1002 format('* ',a80,' *')
142 c 1.2. ==> A priori, aucune ligne voulue n'est acceptable
144 do 12 , iaux = 1 , nblign
148 #ifdef _DEBUG_HOMARD_
149 write (ulsort,texte(langue,4)) mess14(langue,3,1), nbfseg
150 write (ulsort,90002) 'lgtabl', lgtabl
151 write (ulsort,93080) (nomgrl(iaux),iaux=1,lgtabl)
155 c 2. on parcourt toutes les familles de mailles du maillage frontiere
156 c pour reperer les groupes de la liste qui sont effectivement dans
157 c le maillage frontiere
160 cgn write (ulsort,93080) (nomgrf(iaux),iaux=1,20)
163 if ( codret.eq.0 ) then
165 #ifdef _DEBUG_HOMARD_
166 write (ulsort,90015) 'Famille ', fam, ', de numero', numfam(fam)
169 c 2.1. ==> la famille est-elle a traiter ?
171 do 21 , iaux = 1, nbfseg
173 cgn write (ulsort,90112) 'lifami', iaux, lifami(iaux)
174 if ( numfam(fam).eq.lifami(iaux) ) then
182 c 2.2. ==> on parcourt tous les groupes entrant dans la
183 c definition de cette famille
187 nbgr = (pointf(fam)-pointf(fam-1))/10
191 c 2.2.1. ==> nom du groupe associe
192 c adresse du debut du groupe numero gr de la famille fam
194 if ( codret.eq.0 ) then
196 iaux = pointf(fam-1)+1+10*(gr-1)
198 c recuperation du nom du groupe numero gr dans la famille
200 call uts8ch ( nomgrf(iaux), 80, groupf,
201 > ulsort, langue, codret )
205 if ( codret.eq.0 ) then
207 c longueur utile du nom du groupe
208 call utlgut ( lgngrf, groupf, ulsort, langue, codret )
212 #ifdef _DEBUG_HOMARD_
213 write (ulsort,93020) 'groupf', groupf
214 write (ulsort,90002) 'lgngrf', lgngrf
217 c 2.2.2. ==> on cherche si le groupe est deja present dans la liste
219 do 222 , lig = 1 , nblign
221 if ( codret.eq.0 ) then
222 c adresse du debut du groupe associe a la ligne lig
223 iaux = pointl(lig-1) + 1
225 c recuperation du nom du groupe associe a la ligne lig
226 call uts8ch ( nomgrl(iaux), 80, groupl,
227 > ulsort, langue, codret )
231 if ( codret.eq.0 ) then
233 c longueur utile du nom du groupe
234 call utlgut ( lgngrl, groupl, ulsort, langue, codret )
238 c ......... si le groupe de la ligne et le groupe dans la liste
239 c ......... coincident, on passe au groupe suivant dans la famille
240 c ......... on note ce groupe
242 if ( lgngrl.eq.lgngrf ) then
244 if ( groupl(1:lgngrl).eq.groupf(1:lgngrf) ) then
259 #ifdef _DEBUG_HOMARD_
260 write (ulsort,*) 'linugr'
261 write (ulsort,91020) (linugr(iaux),iaux=1,nblign)
265 c 3. Si au moins un groupe de la liste n'est pas dans le maillage
266 c frontiere, il faut recreer cette liste en eliminant ces groupes.
268 c 3.1. ==> Decompte du nombre de groupes absents
269 #ifdef _DEBUG_HOMARD_
270 write (ulsort,90002) '3.1. Decompte ; codret', codret
273 if ( codret.eq.0 ) then
276 do 31 , iaux = 1 , nblign
277 if ( linugr(iaux).eq.0 ) then
284 #ifdef _DEBUG_HOMARD_
285 write (ulsort,90002) 'nblnew', nblnew
288 if ( nblnew.lt.nblign ) then
290 c 3.2. ==> Allocation de la nouvelle structure
292 if ( codret.eq.0 ) then
297 #ifdef _DEBUG_HOMARD_
298 write (ulsort,texte(langue,3)) 'UTATPC', nompro
300 call utaptc ( ntrava, iaux, jaux,
302 > pointn, pttgrn, ptngrn,
303 > ulsort, langue, codret )
306 #ifdef _DEBUG_HOMARD_
307 call gmprsx (nompro,ntrava )
308 cgn call gmprsx (nompro,ntrava//'.Pointeur' )
309 cgn call gmprsx (nompro,ntrava//'.Table' )
310 cgn call gmprsx (nompro,ntrava//'.Taille' )
313 c 3.3. ==> Remplissage de la nouvelle structure
317 write (ulsort,texte(langue,5))
322 c 3.3.1. ==> Tous les groupes sont absents
324 if ( nblnew.eq.0 ) then
326 write (ulsort,texte(langue,6))
328 c 3.3.2. ==> Au moins un groupe est absent, mais pas tous
329 c On transfere les valeurs
335 if ( codret.eq.0 ) then
337 do 33 , lig = 1 , nblign
339 if ( codret.eq.0 ) then
341 if ( linugr(lig).ne.0 ) then
342 #ifdef _DEBUG_HOMARD_
343 write(ulsort,90002) 'Transfert ligne', lig
346 kaux = pointl(lig) - pointl(lig-1)
347 cgn write(ulsort,*) 'kaux', kaux
350 lgtnew = lgtnew + kaux
351 jaux = imem(pointn+nblnew-1)
352 imem(pointn+nblnew) = jaux + kaux
354 do 331 , iaux = 1, kaux
355 imem(pttgrn+jaux-1+iaux) = taigrl(pointl(lig-1)+iaux)
356 smem(ptngrn+jaux-1+iaux) = nomgrl(pointl(lig-1)+iaux)
361 c adresse du debut du groupe associe a la ligne lig
362 iaux = pointl(lig-1) + 1
364 c recuperation du nom du groupe associe a la ligne lig
365 call uts8ch ( nomgrl(iaux), 80, groupl,
366 > ulsort, langue, codret )
368 write (ulsort,1002) groupl
382 c 3.4. ==> Ajustement des tailles de la structure
383 #ifdef _DEBUG_HOMARD_
384 write (ulsort,90002) '3.4. Ajustement ; codret', codret
386 c 3.4.1. ==> Ajustement de la structure
388 if ( codret.eq.0 ) then
391 #ifdef _DEBUG_HOMARD_
392 write (ulsort,texte(langue,3)) 'UTATPC', nompro
394 call utaptc ( ntrava, iaux, jaux,
396 > pointn, pttgrn, ptngrn,
397 > ulsort, langue, codret )
401 c 3.4.2. ==> Transfert
403 if ( codret.eq.0 ) then
405 call gmlboj ( ncafdg, codret )
409 if ( codret.eq.0 ) then
413 #ifdef _DEBUG_HOMARD_
414 call gmprsx (nompro,ncafdg )
415 call gmprsx (nompro,ncafdg//'.Pointeur' )
416 call gmprsx (nompro,ncafdg//'.Table' )
417 call gmprsx (nompro,ncafdg//'.Taille' )
428 if ( codret.ne.0 ) then
432 write (ulsort,texte(langue,1)) 'Sortie', nompro
433 write (ulsort,texte(langue,2)) codret
437 #ifdef _DEBUG_HOMARD_
438 write (ulsort,texte(langue,1)) 'Sortie', nompro