--- /dev/null
+ subroutine sfslin ( lenoeu, noeud1, noeud2,
+ > numlig, unst2x, epsid2,
+ > geocoo, abscur,
+ > numnoe, lignoe, abscno,
+ > typlig, somseg, seglig,
+ > coop,
+ > ulsort, langue, codret)
+c ______________________________________________________________________
+c H O M A R D
+c
+c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
+c
+c Version originale enregistree le 18 juin 1996 sous le numero 96036
+c aupres des huissiers de justice Simart et Lavoir a Clamart
+c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
+c aupres des huissiers de justice
+c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
+c
+c HOMARD est une marque deposee d'Electricite de France
+c
+c Copyright EDF 1996
+c Copyright EDF 1998
+c Copyright EDF 2002
+c Copyright EDF 2020
+c ______________________________________________________________________
+c
+c Suivi de Frontiere - Suivi des LIgnes - placement d'un Noeud
+c - - - -- -
+c ______________________________________________________________________
+c . . . . .
+c . nom . e/s . taille . description .
+c .____________________________________________________________________.
+c . lenoeu . e . 1 . noeud a bouger .
+c . noeud1 . e . 1 . noeud voisin 1 de lenoeu sur l'arete .
+c . noeud2 . e . 1 . noeud voisin 2 de lenoeu sur l'arete .
+c . numlig . e . 1 . numero de la ligne de la frontiere .
+c . unst2x . e . 1 . inverse de la taille maximale au carre .
+c . epsid2 . e . 1 . precision relative pour carre de distance .
+c . geocoo . e .sfnbso**. coordonnees des sommets de la frontiere .
+c . abscur . e . sfnbse . abscisse curviligne des somm des segments .
+c . numnoe . e . mcnvnf . liste des noeuds de calcul sur le bord .
+c . lignoe . e . mcnvnf . liste lignes pour ces noeuds .
+c . abscno . e . mcnvnf . abscisse curviligne de ces noeuds .
+c . typlig . e . sfnbli . type de la ligne .
+c . . . . 0 : ligne ouverte, a 2 extremites .
+c . . . . 1 : ligne fermee .
+c . somseg . e . sfnbse . liste des sommets des lignes separees par .
+c des 0 .
+c . seglig . e .0:sfnbli. pointeur dans le tableau somseg : les .
+c . . . . segments de la ligne i sont aux places de .
+c . . . . seglig(i-1)+1 a seglig(i)-1 inclus .
+c . coop . es . sdim . nouvelles coordonnees de lenoeu .
+c . ulsort . e . 1 . numero d'unite logique de la liste standard.
+c . langue . e . 1 . langue des messages .
+c . . . . 1 : francais, 2 : anglais .
+c . codret . es . 1 . code de retour des modules .
+c . . . . 0 : pas de probleme .
+c . . . . 1 : impossible de retrouver les noeuds .
+c . . . . voisins .
+c . . . . 2 : impossible de trouver le segment .
+c . . . . contenant le noeud .
+c ______________________________________________________________________
+c
+c====
+c 0. declarations et dimensionnement
+c====
+c
+c 0.1. ==> generalites
+c
+ implicit none
+ save
+c
+ character*6 nompro
+ parameter ( nompro = 'SFSLIN' )
+c
+#include "nblang.h"
+c
+c 0.2. ==> communs
+c
+#include "envex1.h"
+#include "envca1.h"
+c
+#include "front1.h"
+#include "front2.h"
+#include "impr02.h"
+c
+c 0.3. ==> arguments
+c
+ integer lenoeu, noeud1, noeud2
+ integer numlig
+ integer numnoe(mcnvnf), lignoe(mcnvnf)
+ integer typlig(sfnbli), somseg(sfnbse), seglig(0:sfnbli)
+c
+ double precision unst2x, epsid2
+ double precision geocoo(sfnbso,sdim)
+ double precision abscur(sfnbse)
+ double precision abscno(mcnvnf)
+ double precision coop(sdim)
+c
+ integer ulsort, langue, codret
+c
+c 0.4. ==> variables locales
+c
+ integer iaux, jaux, kaux
+ integer seg, seg1, seg2
+ integer nupass, nbpass
+c
+ double precision abscnn(2), abscn1, abscn2, abscnm
+ double precision daux, lgdeb, lgfin
+ double precision cooa(3)
+ double precision cooini(3), coopst(3), dist
+c
+ integer nbmess
+ parameter ( nbmess = 10 )
+ character*80 texte(nblang,nbmess)
+c
+c 0.5. ==> initialisations
+c ______________________________________________________________________
+c
+c====
+c 1. initialisations
+c====
+c
+cgn ulsort = lenoeu
+#include "impr01.h"
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,texte(langue,1)) 'Entree', nompro
+ call dmflsh (iaux)
+#endif
+c
+ texte(1,4) = '(''.. '',a,i10,'' a deplacer'')'
+ texte(1,5) = '(''... Coordonnees :'',3g17.9)'
+ texte(1,6) = '(''.. Il est entre les '',a,i10,'' et'',i10)'
+ texte(1,7) =
+ > '(''.... Abscisse curviligne du noeud'',i10,'' :'',g17.9)'
+ texte(1,8) = '(''.... Abscisse curviligne '',a,'' :'',g17.9)'
+ texte(1,9) =
+ >'(''.. Impossible de trouver le '',a,i10,'' sur la frontiere.'')'
+ texte(1,10) = '(''.. Impossible de trouver le segment associe.'')'
+c
+ texte(2,4) = '(''... '',a,'' # '',i10,'' to move'')'
+ texte(2,5) = '(''... Coordinates :'',3g17.9)'
+ texte(2,6) =
+ > '(''... It is between '',a,'' # '',i10,'' and #'',i10)'
+ texte(2,7) =
+ > '(''.... Current absciss of the node'',i10,'' :'',g17.9)'
+ texte(2,8) = '(''.... Current absciss '',a,'' :'',g17.9)'
+ texte(2,9) =
+ > '(''.. The '',a,i10,'' cannot be found on boundary.'')'
+ texte(2,10) = '(''.. The edge of boundary cannot be found.'')'
+c
+#include "impr03.h"
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,texte(langue,4)) mess14(langue,2,-1), lenoeu
+ write (ulsort,texte(langue,5)) (coop(iaux),iaux=1,sdim)
+ write (ulsort,texte(langue,6)) mess14(langue,3,-1),
+ > noeud1, noeud2
+#endif
+c
+ codret = 0
+c
+c====
+c 2. Recherche des abscisses curvilignes associes aux noeuds voisins
+c====
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,90002) '2. Recherche abscisse ; codret', codret
+#endif
+c
+ do 21 , iaux = 1 , 2
+c
+ if ( codret.eq.0 ) then
+c
+ if ( iaux.eq.1 ) then
+ kaux = noeud1
+ else
+ kaux = noeud2
+ endif
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,90002) '.... '//mess14(langue,2,-1), kaux
+#endif
+c
+ do 211 , jaux = 1 , mcnvnf
+c
+ if ( numnoe(jaux).eq.kaux ) then
+ if ( lignoe(jaux).eq.numlig ) then
+ daux = abs(abscno(jaux))
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,texte(langue,7)) jaux, daux
+#endif
+ goto 212
+ endif
+ endif
+c
+ 211 continue
+c
+ codret = 1
+c
+ endif
+c
+ 212 continue
+c
+ if ( codret.eq.0 ) then
+c
+ abscnn(iaux) = daux
+c
+ endif
+c
+ 21 continue
+c
+c====
+c 3. Positionnement du noeud a bouger
+c====
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,90002) '3. Positionnement ; codret', codret
+#endif
+c
+c 3.1. ==> Caracteristique de la ligne
+c
+ if ( codret.eq.0 ) then
+c
+ if ( typlig(numlig).eq.0 ) then
+ nbpass = 1
+ else
+ nbpass = 2
+ endif
+c
+ seg1 = seglig(numlig-1)+1
+ seg2 = seglig(numlig )-2
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,90006) 'Pointeurs ligne', numlig,
+ > ' de', seg1,' a ', seg2
+ write (ulsort,90012) '==> Sommets extremites de la ligne',
+ > numlig, somseg(seg1), somseg(seg2+1)
+ write (ulsort,90004) 'abscisse debut', abscur(seg1)
+ write (ulsort,90004) 'abscisse fin ', abscur(seg2+1)
+ write (ulsort,90002) 'nbpass', nbpass
+#endif
+c
+ if ( nbpass.gt.0 ) then
+c
+ do 31 , iaux = 1 , sdim
+ cooini(iaux) = coop(iaux)
+ 31 continue
+c
+ endif
+c
+ endif
+c
+ abscn1 = abscnn(1)
+ abscn2 = abscnn(2)
+c
+ do 30 , nupass = 1 , nbpass
+cgn write (ulsort,*) ' '
+cgn write (ulsort,90002) 'Passage numero', nupass
+c
+c 3.2. ==> La nouvelle abscisse curviligne
+c . Au premier passage, on calcule entre les deux noeuds
+c . A l'eventuel second, c'est que l'on a une extremite ; on
+c doit tester le chemin reciproque pour les cas ou la ligne
+c serait fermee.
+c
+ if ( codret.eq.0 ) then
+c
+c
+ if ( nupass.eq.1 ) then
+c
+ abscnm = 0.5d0 * (abscn1+abscn2)
+c
+ else
+c
+ if ( abscn2.gt.abscn1 ) then
+ lgfin = abscur(seg2+1) - abscn2
+ lgdeb = abscn1 - abscur(seg1)
+cgn write (ulsort,90004) 'de n2 a la fin', lgfin
+cgn write (ulsort,90004) 'du debut a n1 ', lgdeb
+ else
+ lgfin = abscur(seg2+1) - abscn1
+ lgdeb = abscn2 - abscur(seg1)
+cgn write (ulsort,90004) 'de n1 a la fin', lgfin
+cgn write (ulsort,90004) 'du debut a n2 ', lgdeb
+ daux = (abscn2-abscur(seg1)) - (abscur(seg2+1)-abscn1)
+ endif
+ if ( lgfin.gt.lgdeb ) then
+ abscnm = abscur(seg2+1) - 0.5d0*(lgfin-lgdeb)
+ else
+ abscnm = abscur(seg1) + 0.5d0*(lgdeb-lgfin)
+ endif
+c
+ do 32 , iaux = 1 , sdim
+ coopst(iaux) = coop(iaux)
+ 32 continue
+c
+ endif
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,90002) mess14(langue,2,-1), lenoeu
+ write (ulsort,texte(langue,8)) 'noeud', abscnm
+#endif
+c
+ endif
+c
+c 3.3. ==> Recherche du segment
+c Remarque : le noeud a bouger ne peut pas etre une des
+c extremites de la ligne car il est situe entre
+c noeud1 et noeud2, eux-memes sur cette ligne
+c
+ if ( codret.eq.0 ) then
+c
+ seg = 0
+c
+ do 33 , kaux = seg1 , seg2
+c
+ if ( abscnm.ge.abscur(kaux) .and.
+ > abscnm.le.abscur(kaux+1) ) then
+c
+ seg = kaux
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,90006) '.... Appartiendra au segment', seg
+ write (ulsort,texte(langue,8)) 'debut', abscur(seg)
+ write (ulsort,texte(langue,8)) 'fin ', abscur(seg+1)
+#endif
+c
+c 3.3.2. ==> Le noeud est-il le premier point du segment ?
+c
+ daux = 0.d0
+ do 332 , iaux = 1 , sdim
+ cooa(iaux) = geocoo(somseg(kaux),iaux)
+ daux = daux + (cooa(iaux)-coop(iaux))**2
+ 332 continue
+c
+c 3.3.3. ==> Si non, on doit bouger le noeud
+c Si oui, c'est parfait : le noeud est deja sur la frontiere
+c
+ if ( daux*unst2x.gt.epsid2 ) then
+c
+c A M B
+c x--------------------------o------------x
+c
+c On procede par proportionnalite :
+c AM = AB *(d(A,M)/d(A,B))
+c
+ daux = ( abscnm - abscur(kaux) ) /
+ > ( abscur(kaux+1) - abscur(kaux) )
+c
+ do 333 , iaux = 1 , sdim
+ coop(iaux) = cooa(iaux) +
+ > daux * ( geocoo(somseg(kaux+1),iaux)-cooa(iaux))
+ 333 continue
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,texte(langue,5)) (coop(iaux),iaux=1,sdim)
+#endif
+c
+#ifdef _DEBUG_HOMARD_
+ else
+ write (ulsort,90006) '.. Le noeud est extremite du segment', kaux
+#endif
+c
+ endif
+c
+ goto 30
+c
+ endif
+c
+ 33 continue
+c
+ if ( seg.eq.0 ) then
+ codret = 2
+ endif
+c
+ endif
+c
+ 30 continue
+c
+c 3.4. ==> Si l'arete est sur une ligne fermee, on compare les deux
+c solutions. L'idee est que la bonne est celle ou on va
+c le moins loin !
+c
+ if ( codret.eq.0 ) then
+c
+ if ( nbpass.gt.0 ) then
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,*) ' '
+ write (ulsort,90004) 'cooini', (cooini(iaux),iaux=1,sdim)
+ write (ulsort,90004) 'coopst', (coopst(iaux),iaux=1,sdim)
+ write (ulsort,90004) 'coop ', (coop(iaux),iaux=1,sdim)
+#endif
+c
+ dist = 0.d0
+ daux = 0.d0
+ do 341 , iaux = 1 , sdim
+ dist = dist + (cooini(iaux) - coopst(iaux))**2
+ daux = daux + (cooini(iaux) - coop(iaux))**2
+ 341 continue
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,90004) 'dist', dist
+ write (ulsort,90004) 'daux', daux
+#endif
+c
+ if ( dist.lt.daux ) then
+ do 342 , iaux = 1 , sdim
+ coop(iaux) = coopst(iaux)
+ 342 continue
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,*) 'On reprend la premiere projection :'
+ write (ulsort,90004) 'coop ', (coop(iaux),iaux=1,sdim)
+#endif
+ endif
+c
+ endif
+c
+ endif
+c
+c====
+c 4. la fin
+c====
+c
+ if ( codret.ne.0 ) then
+c
+#include "envex2.h"
+c
+ write (ulsort,texte(langue,1)) 'Sortie', nompro
+ write (ulsort,texte(langue,2)) codret
+ write (ulsort,texte(langue,4)) mess14(langue,2,-1), lenoeu
+ write (ulsort,texte(langue,6)) mess14(langue,3,-1),
+ > noeud1, noeud2
+ if ( codret.eq.1 ) then
+ write (ulsort,texte(langue,9)) mess14(langue,1,-1), kaux
+ elseif ( codret.eq.2 ) then
+ write (ulsort,texte(langue,10))
+ endif
+c
+ endif
+c
+#ifdef _DEBUG_HOMARD_
+ write (ulsort,texte(langue,1)) 'Sortie', nompro
+ call dmflsh (iaux)
+#endif
+c
+cgn ulsort=1
+c
+ end
