src/tool/Suivi_Frontiere/sfslin.F

   1       subroutine sfslin ( lenoeu, noeud1, noeud2,
   2      >                    numlig, unst2x, epsid2,
   3      >                    geocoo, abscur,
   4      >                    numnoe, lignoe, abscno,
   5      >                    typlig, somseg, seglig,
   6      >                    coop,
   7      >                    ulsort, langue, codret)
   8 c ______________________________________________________________________
   9 c                             H O M A R D
  10 c
  11 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  12 c
  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
  18 c
  19 c    HOMARD est une marque deposee d'Electricite de France
  20 c
  21 c Copyright EDF 1996
  22 c Copyright EDF 1998
  23 c Copyright EDF 2002
  24 c Copyright EDF 2020
  25 c ______________________________________________________________________
  26 c
  27 c   Suivi de Frontiere - Suivi des LIgnes - placement d'un Noeud
  28 c   -        -           -         --                      -
  29 c ______________________________________________________________________
  30 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  .
  48 c                           des 0                                      .
  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     .
  59 c .        .     .        .     voisins                                .
  60 c .        .     .        . 2 : impossible de trouver le segment       .
  61 c .        .     .        .     contenant le noeud                     .
  62 c ______________________________________________________________________
  63 c
  64 c====
  65 c 0. declarations et dimensionnement
  66 c====
  67 c
  68 c 0.1. ==> generalites
  69 c
  70       implicit none
  71       save
  72 c
  73       character*6 nompro
  74       parameter ( nompro = 'SFSLIN' )
  75 c
  76 #include "nblang.h"
  77 c
  78 c 0.2. ==> communs
  79 c
  80 #include "envex1.h"
  81 #include "envca1.h"
  82 c
  83 #include "front1.h"
  84 #include "front2.h"
  85 #include "impr02.h"
  86 c
  87 c 0.3. ==> arguments
  88 c
  89       integer lenoeu, noeud1, noeud2
  90       integer numlig
  91       integer numnoe(mcnvnf), lignoe(mcnvnf)
  92       integer typlig(sfnbli), somseg(sfnbse), seglig(0:sfnbli)
  93 c
  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)
  99 c
 100       integer ulsort, langue, codret
 101 c
 102 c 0.4. ==> variables locales
 103 c
 104       integer iaux, jaux, kaux
 105       integer seg, seg1, seg2
 106       integer nupass, nbpass
 107 c
 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
 112 c
 113       integer nbmess
 114       parameter ( nbmess = 10 )
 115       character*80 texte(nblang,nbmess)
 116 c
 117 c 0.5. ==> initialisations
 118 c ______________________________________________________________________
 119 c
 120 c====
 121 c 1. initialisations
 122 c====
 123 c
 124 cgn      ulsort = lenoeu
 125 #include "impr01.h"
 126 c
 127 #ifdef _DEBUG_HOMARD_
 128       write (ulsort,texte(langue,1)) 'Entree', nompro
 129       call dmflsh (iaux)
 130 #endif
 131 c
 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)'
 135       texte(1,7) =
 136      > '(''.... Abscisse curviligne du noeud'',i10,'' :'',g17.9)'
 137       texte(1,8) = '(''.... Abscisse curviligne '',a,'' :'',g17.9)'
 138       texte(1,9) =
 139      >'(''.. Impossible de trouver le '',a,i10,'' sur la frontiere.'')'
 140       texte(1,10) = '(''.. Impossible de trouver le segment associe.'')'
 141 c
 142       texte(2,4) = '(''... '',a,'' # '',i10,'' to move'')'
 143       texte(2,5) = '(''... Coordinates :'',3g17.9)'
 144       texte(2,6) =
 145      > '(''... It is between '',a,'' # '',i10,'' and #'',i10)'
 146       texte(2,7) =
 147      > '(''.... Current absciss of the node'',i10,'' :'',g17.9)'
 148       texte(2,8) = '(''.... Current absciss '',a,'' :'',g17.9)'
 149       texte(2,9) =
 150      > '(''.. The '',a,i10,'' cannot be found on boundary.'')'
 151       texte(2,10) = '(''.. The edge of boundary cannot be found.'')'
 152 c
 153 #include "impr03.h"
 154 c
 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),
 159      >                               noeud1, noeud2
 160 #endif
 161 c
 162       codret = 0
 163 c
 164 c====
 165 c 2. Recherche des abscisses curvilignes associes aux noeuds voisins
 166 c====
 167 #ifdef _DEBUG_HOMARD_
 168       write (ulsort,90002) '2. Recherche abscisse ; codret', codret
 169 #endif
 170 c
 171       do 21 , iaux = 1 , 2
 172 c
 173         if ( codret.eq.0 ) then
 174 c
 175         if ( iaux.eq.1 ) then
 176           kaux = noeud1
 177         else
 178           kaux = noeud2
 179         endif
 180 #ifdef _DEBUG_HOMARD_
 181       write (ulsort,90002) '.... '//mess14(langue,2,-1), kaux
 182 #endif
 183 c
 184         do 211 , jaux = 1 , mcnvnf
 185 c
 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
 191 #endif
 192               goto 212
 193             endif
 194           endif
 195 c
 196   211   continue
 197 c
 198         codret = 1
 199 c
 200         endif
 201 c
 202   212  continue
 203 c
 204         if ( codret.eq.0 ) then
 205 c
 206         abscnn(iaux) = daux
 207 c
 208         endif
 209 c
 210    21 continue
 211 c
 212 c====
 213 c 3. Positionnement du noeud a bouger
 214 c====
 215 #ifdef _DEBUG_HOMARD_
 216       write (ulsort,90002) '3. Positionnement ; codret', codret
 217 #endif
 218 c
 219 c 3.1. ==> Caracteristique de la ligne
 220 c
 221       if ( codret.eq.0 ) then
 222 c
 223       if ( typlig(numlig).eq.0 ) then
 224         nbpass = 1
 225       else
 226         nbpass = 2
 227       endif
 228 c
 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
 239 #endif
 240 c
 241       if ( nbpass.gt.0 ) then
 242 c
 243         do 31 , iaux = 1 , sdim
 244           cooini(iaux) = coop(iaux)
 245    31   continue
 246 c
 247       endif
 248 c
 249       endif
 250 c
 251       abscn1 = abscnn(1)
 252       abscn2 = abscnn(2)
 253 c
 254       do 30 , nupass = 1 , nbpass
 255 cgn        write (ulsort,*) ' '
 256 cgn        write (ulsort,90002) 'Passage numero', nupass
 257 c
 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
 262 c          serait fermee.
 263 c
 264         if ( codret.eq.0 ) then
 265 c
 266 c
 267         if ( nupass.eq.1 ) then
 268 c
 269           abscnm = 0.5d0 * (abscn1+abscn2)
 270 c
 271         else
 272 c
 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
 278           else
 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)
 284           endif
 285           if ( lgfin.gt.lgdeb ) then
 286             abscnm = abscur(seg2+1) - 0.5d0*(lgfin-lgdeb)
 287           else
 288             abscnm = abscur(seg1) + 0.5d0*(lgdeb-lgfin)
 289           endif
 290 c
 291           do 32 , iaux = 1 , sdim
 292             coopst(iaux) = coop(iaux)
 293    32     continue
 294 c
 295         endif
 296 c
 297 #ifdef _DEBUG_HOMARD_
 298         write (ulsort,90002) mess14(langue,2,-1), lenoeu
 299         write (ulsort,texte(langue,8)) 'noeud', abscnm
 300 #endif
 301 c
 302         endif
 303 c
 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
 308 c
 309       if ( codret.eq.0 ) then
 310 c
 311       seg = 0
 312 c
 313       do 33 , kaux = seg1 , seg2
 314 c
 315         if ( abscnm.ge.abscur(kaux) .and.
 316      >       abscnm.le.abscur(kaux+1) ) then
 317 c
 318           seg = kaux
 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)
 323 #endif
 324 c
 325 c 3.3.2. ==> Le noeud est-il le premier point du segment ?
 326 c
 327           daux = 0.d0
 328           do 332 , iaux = 1 , sdim
 329             cooa(iaux) = geocoo(somseg(kaux),iaux)
 330             daux = daux + (cooa(iaux)-coop(iaux))**2
 331   332     continue
 332 c
 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
 335 c
 336           if ( daux*unst2x.gt.epsid2 ) then
 337 c
 338 c         A                          M            B
 339 c         x--------------------------o------------x
 340 c
 341 c         On procede par proportionnalite :
 342 c          AM = AB *(d(A,M)/d(A,B))
 343 c
 344             daux = ( abscnm - abscur(kaux) ) /
 345      >             ( abscur(kaux+1) - abscur(kaux) )
 346 c
 347             do 333 , iaux = 1 , sdim
 348               coop(iaux) = cooa(iaux) +
 349      >                 daux * ( geocoo(somseg(kaux+1),iaux)-cooa(iaux))
 350   333       continue
 351 #ifdef _DEBUG_HOMARD_
 352       write (ulsort,texte(langue,5)) (coop(iaux),iaux=1,sdim)
 353 #endif
 354 c
 355 #ifdef _DEBUG_HOMARD_
 356           else
 357       write (ulsort,90006) '.. Le noeud est extremite du segment', kaux
 358 #endif
 359 c
 360           endif
 361 c
 362           goto 30
 363 c
 364         endif
 365 c
 366    33 continue
 367 c
 368       if ( seg.eq.0 ) then
 369         codret = 2
 370       endif
 371 c
 372       endif
 373 c
 374    30 continue
 375 c
 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
 378 c          le moins loin !
 379 c
 380       if ( codret.eq.0 ) then
 381 c
 382       if ( nbpass.gt.0 ) then
 383 c
 384 #ifdef _DEBUG_HOMARD_
 385         write (ulsort,*) ' '
 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)
 389 #endif
 390 c
 391         dist = 0.d0
 392         daux = 0.d0
 393         do 341 , iaux = 1 , sdim
 394           dist = dist + (cooini(iaux) - coopst(iaux))**2
 395           daux = daux + (cooini(iaux) - coop(iaux))**2
 396   341   continue
 397 #ifdef _DEBUG_HOMARD_
 398         write (ulsort,90004) 'dist', dist
 399         write (ulsort,90004) 'daux', daux
 400 #endif
 401 c
 402         if ( dist.lt.daux ) then
 403           do 342 , iaux = 1 , sdim
 404             coop(iaux) = coopst(iaux)
 405   342     continue
 406 #ifdef _DEBUG_HOMARD_
 407         write (ulsort,*) 'On reprend la premiere projection :'
 408         write (ulsort,90004) 'coop  ', (coop(iaux),iaux=1,sdim)
 409 #endif
 410         endif
 411 c
 412       endif
 413 c
 414       endif
 415 c
 416 c====
 417 c 4. la fin
 418 c====
 419 c
 420       if ( codret.ne.0 ) then
 421 c
 422 #include "envex2.h"
 423 c
 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),
 428      >                               noeud1, noeud2
 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))
 433       endif
 434 c
 435       endif
 436 c
 437 #ifdef _DEBUG_HOMARD_
 438       write (ulsort,texte(langue,1)) 'Sortie', nompro
 439       call dmflsh (iaux)
 440 #endif
 441 c
 442 cgn      ulsort=1
 443 c
 444       end