1 subroutine sfslin ( lenoeu, noeud1, noeud2,
2 > numlig, unst2x, epsid2,
4 > numnoe, lignoe, abscno,
5 > typlig, somseg, seglig,
7 > ulsort, langue, codret)
8 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 - Suivi des LIgnes - placement d'un Noeud
29 c ______________________________________________________________________
31 c . nom . e/s . taille . description .
32 c .____________________________________________________________________.
33 c . lenoeu . e . 1 . noeud a bouger .
34 c . noeud1 . e . 1 . noeud voisin 1 de lenoeu sur l'arete .
35 c . noeud2 . e . 1 . noeud voisin 2 de lenoeu sur l'arete .
36 c . numlig . e . 1 . numero de la ligne de la frontiere .
37 c . unst2x . e . 1 . inverse de la taille maximale au carre .
38 c . epsid2 . e . 1 . precision relative pour carre de distance .
39 c . geocoo . e .sfnbso**. coordonnees des sommets de la frontiere .
40 c . abscur . e . sfnbse . abscisse curviligne des somm des segments .
41 c . numnoe . e . mcnvnf . liste des noeuds de calcul sur le bord .
42 c . lignoe . e . mcnvnf . liste lignes pour ces noeuds .
43 c . abscno . e . mcnvnf . abscisse curviligne de ces noeuds .
44 c . typlig . e . sfnbli . type de la ligne .
45 c . . . . 0 : ligne ouverte, a 2 extremites .
46 c . . . . 1 : ligne fermee .
47 c . somseg . e . sfnbse . liste des sommets des lignes separees par .
49 c . seglig . e .0:sfnbli. pointeur dans le tableau somseg : les .
50 c . . . . segments de la ligne i sont aux places de .
51 c . . . . seglig(i-1)+1 a seglig(i)-1 inclus .
52 c . coop . es . sdim . nouvelles coordonnees de lenoeu .
53 c . ulsort . e . 1 . numero d'unite logique de la liste standard.
54 c . langue . e . 1 . langue des messages .
55 c . . . . 1 : francais, 2 : anglais .
56 c . codret . es . 1 . code de retour des modules .
57 c . . . . 0 : pas de probleme .
58 c . . . . 1 : impossible de retrouver les noeuds .
60 c . . . . 2 : impossible de trouver le segment .
61 c . . . . contenant le noeud .
62 c ______________________________________________________________________
65 c 0. declarations et dimensionnement
68 c 0.1. ==> generalites
74 parameter ( nompro = 'SFSLIN' )
89 integer lenoeu, noeud1, noeud2
91 integer numnoe(mcnvnf), lignoe(mcnvnf)
92 integer typlig(sfnbli), somseg(sfnbse), seglig(0:sfnbli)
94 double precision unst2x, epsid2
95 double precision geocoo(sfnbso,sdim)
96 double precision abscur(sfnbse)
97 double precision abscno(mcnvnf)
98 double precision coop(sdim)
100 integer ulsort, langue, codret
102 c 0.4. ==> variables locales
104 integer iaux, jaux, kaux
105 integer seg, seg1, seg2
106 integer nupass, nbpass
108 double precision abscnn(2), abscn1, abscn2, abscnm
109 double precision daux, lgdeb, lgfin
110 double precision cooa(3)
111 double precision cooini(3), coopst(3), dist
114 parameter ( nbmess = 10 )
115 character*80 texte(nblang,nbmess)
117 c 0.5. ==> initialisations
118 c ______________________________________________________________________
127 #ifdef _DEBUG_HOMARD_
128 write (ulsort,texte(langue,1)) 'Entree', nompro
132 texte(1,4) = '(''.. '',a,i10,'' a deplacer'')'
133 texte(1,5) = '(''... Coordonnees :'',3g17.9)'
134 texte(1,6) = '(''.. Il est entre les '',a,i10,'' et'',i10)'
136 > '(''.... Abscisse curviligne du noeud'',i10,'' :'',g17.9)'
137 texte(1,8) = '(''.... Abscisse curviligne '',a,'' :'',g17.9)'
139 >'(''.. Impossible de trouver le '',a,i10,'' sur la frontiere.'')'
140 texte(1,10) = '(''.. Impossible de trouver le segment associe.'')'
142 texte(2,4) = '(''... '',a,'' # '',i10,'' to move'')'
143 texte(2,5) = '(''... Coordinates :'',3g17.9)'
145 > '(''... It is between '',a,'' # '',i10,'' and #'',i10)'
147 > '(''.... Current absciss of the node'',i10,'' :'',g17.9)'
148 texte(2,8) = '(''.... Current absciss '',a,'' :'',g17.9)'
150 > '(''.. The '',a,i10,'' cannot be found on boundary.'')'
151 texte(2,10) = '(''.. The edge of boundary cannot be found.'')'
155 #ifdef _DEBUG_HOMARD_
156 write (ulsort,texte(langue,4)) mess14(langue,2,-1), lenoeu
157 write (ulsort,texte(langue,5)) (coop(iaux),iaux=1,sdim)
158 write (ulsort,texte(langue,6)) mess14(langue,3,-1),
165 c 2. Recherche des abscisses curvilignes associes aux noeuds voisins
167 #ifdef _DEBUG_HOMARD_
168 write (ulsort,90002) '2. Recherche abscisse ; codret', codret
173 if ( codret.eq.0 ) then
175 if ( iaux.eq.1 ) then
180 #ifdef _DEBUG_HOMARD_
181 write (ulsort,90002) '.... '//mess14(langue,2,-1), kaux
184 do 211 , jaux = 1 , mcnvnf
186 if ( numnoe(jaux).eq.kaux ) then
187 if ( lignoe(jaux).eq.numlig ) then
188 daux = abs(abscno(jaux))
189 #ifdef _DEBUG_HOMARD_
190 write (ulsort,texte(langue,7)) jaux, daux
204 if ( codret.eq.0 ) then
213 c 3. Positionnement du noeud a bouger
215 #ifdef _DEBUG_HOMARD_
216 write (ulsort,90002) '3. Positionnement ; codret', codret
219 c 3.1. ==> Caracteristique de la ligne
221 if ( codret.eq.0 ) then
223 if ( typlig(numlig).eq.0 ) then
229 seg1 = seglig(numlig-1)+1
230 seg2 = seglig(numlig )-2
231 #ifdef _DEBUG_HOMARD_
232 write (ulsort,90006) 'Pointeurs ligne', numlig,
233 > ' de', seg1,' a ', seg2
234 write (ulsort,90012) '==> Sommets extremites de la ligne',
235 > numlig, somseg(seg1), somseg(seg2+1)
236 write (ulsort,90004) 'abscisse debut', abscur(seg1)
237 write (ulsort,90004) 'abscisse fin ', abscur(seg2+1)
238 write (ulsort,90002) 'nbpass', nbpass
241 if ( nbpass.gt.0 ) then
243 do 31 , iaux = 1 , sdim
244 cooini(iaux) = coop(iaux)
254 do 30 , nupass = 1 , nbpass
255 cgn write (ulsort,*) ' '
256 cgn write (ulsort,90002) 'Passage numero', nupass
258 c 3.2. ==> La nouvelle abscisse curviligne
259 c . Au premier passage, on calcule entre les deux noeuds
260 c . A l'eventuel second, c'est que l'on a une extremite ; on
261 c doit tester le chemin reciproque pour les cas ou la ligne
264 if ( codret.eq.0 ) then
267 if ( nupass.eq.1 ) then
269 abscnm = 0.5d0 * (abscn1+abscn2)
273 if ( abscn2.gt.abscn1 ) then
274 lgfin = abscur(seg2+1) - abscn2
275 lgdeb = abscn1 - abscur(seg1)
276 cgn write (ulsort,90004) 'de n2 a la fin', lgfin
277 cgn write (ulsort,90004) 'du debut a n1 ', lgdeb
279 lgfin = abscur(seg2+1) - abscn1
280 lgdeb = abscn2 - abscur(seg1)
281 cgn write (ulsort,90004) 'de n1 a la fin', lgfin
282 cgn write (ulsort,90004) 'du debut a n2 ', lgdeb
283 daux = (abscn2-abscur(seg1)) - (abscur(seg2+1)-abscn1)
285 if ( lgfin.gt.lgdeb ) then
286 abscnm = abscur(seg2+1) - 0.5d0*(lgfin-lgdeb)
288 abscnm = abscur(seg1) + 0.5d0*(lgdeb-lgfin)
291 do 32 , iaux = 1 , sdim
292 coopst(iaux) = coop(iaux)
297 #ifdef _DEBUG_HOMARD_
298 write (ulsort,90002) mess14(langue,2,-1), lenoeu
299 write (ulsort,texte(langue,8)) 'noeud', abscnm
304 c 3.3. ==> Recherche du segment
305 c Remarque : le noeud a bouger ne peut pas etre une des
306 c extremites de la ligne car il est situe entre
307 c noeud1 et noeud2, eux-memes sur cette ligne
309 if ( codret.eq.0 ) then
313 do 33 , kaux = seg1 , seg2
315 if ( abscnm.ge.abscur(kaux) .and.
316 > abscnm.le.abscur(kaux+1) ) then
319 #ifdef _DEBUG_HOMARD_
320 write (ulsort,90006) '.... Appartiendra au segment', seg
321 write (ulsort,texte(langue,8)) 'debut', abscur(seg)
322 write (ulsort,texte(langue,8)) 'fin ', abscur(seg+1)
325 c 3.3.2. ==> Le noeud est-il le premier point du segment ?
328 do 332 , iaux = 1 , sdim
329 cooa(iaux) = geocoo(somseg(kaux),iaux)
330 daux = daux + (cooa(iaux)-coop(iaux))**2
333 c 3.3.3. ==> Si non, on doit bouger le noeud
334 c Si oui, c'est parfait : le noeud est deja sur la frontiere
336 if ( daux*unst2x.gt.epsid2 ) then
339 c x--------------------------o------------x
341 c On procede par proportionnalite :
342 c AM = AB *(d(A,M)/d(A,B))
344 daux = ( abscnm - abscur(kaux) ) /
345 > ( abscur(kaux+1) - abscur(kaux) )
347 do 333 , iaux = 1 , sdim
348 coop(iaux) = cooa(iaux) +
349 > daux * ( geocoo(somseg(kaux+1),iaux)-cooa(iaux))
351 #ifdef _DEBUG_HOMARD_
352 write (ulsort,texte(langue,5)) (coop(iaux),iaux=1,sdim)
355 #ifdef _DEBUG_HOMARD_
357 write (ulsort,90006) '.. Le noeud est extremite du segment', kaux
376 c 3.4. ==> Si l'arete est sur une ligne fermee, on compare les deux
377 c solutions. L'idee est que la bonne est celle ou on va
380 if ( codret.eq.0 ) then
382 if ( nbpass.gt.0 ) then
384 #ifdef _DEBUG_HOMARD_
386 write (ulsort,90004) 'cooini', (cooini(iaux),iaux=1,sdim)
387 write (ulsort,90004) 'coopst', (coopst(iaux),iaux=1,sdim)
388 write (ulsort,90004) 'coop ', (coop(iaux),iaux=1,sdim)
393 do 341 , iaux = 1 , sdim
394 dist = dist + (cooini(iaux) - coopst(iaux))**2
395 daux = daux + (cooini(iaux) - coop(iaux))**2
397 #ifdef _DEBUG_HOMARD_
398 write (ulsort,90004) 'dist', dist
399 write (ulsort,90004) 'daux', daux
402 if ( dist.lt.daux ) then
403 do 342 , iaux = 1 , sdim
404 coop(iaux) = coopst(iaux)
406 #ifdef _DEBUG_HOMARD_
407 write (ulsort,*) 'On reprend la premiere projection :'
408 write (ulsort,90004) 'coop ', (coop(iaux),iaux=1,sdim)
420 if ( codret.ne.0 ) then
424 write (ulsort,texte(langue,1)) 'Sortie', nompro
425 write (ulsort,texte(langue,2)) codret
426 write (ulsort,texte(langue,4)) mess14(langue,2,-1), lenoeu
427 write (ulsort,texte(langue,6)) mess14(langue,3,-1),
429 if ( codret.eq.1 ) then
430 write (ulsort,texte(langue,9)) mess14(langue,1,-1), kaux
431 elseif ( codret.eq.2 ) then
432 write (ulsort,texte(langue,10))
437 #ifdef _DEBUG_HOMARD_
438 write (ulsort,texte(langue,1)) 'Sortie', nompro