src/tool/Suivi_Frontiere/sfliso.F

   1       subroutine sfliso ( numnoe, lignoe, abscno,
   2      >                    unst2x, epsid2,
   3      >                    coonoe,
   4      >                    somare, hetare, filare, np2are,
   5      >                    cfaare, famare,
   6      >                    geocoo, abscur,
   7      >                    somseg, seglig, segnoe,
   8      >                    ulsort, langue, codret)
   9 c ______________________________________________________________________
  10 c
  11 c                             H O M A R D
  12 c
  13 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  14 c
  15 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  16 c aupres des huissiers de justice Simart et Lavoir a Clamart
  17 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  18 c aupres des huissiers de justice
  19 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  20 c
  21 c    HOMARD est une marque deposee d'Electricite de France
  22 c
  23 c Copyright EDF 1996
  24 c Copyright EDF 1998
  25 c Copyright EDF 2002
  26 c Copyright EDF 2020
  27 c ______________________________________________________________________
  28 c
  29 c   Suivi de Frontiere - LIen des SOmmets
  30 c   -        -           --       --
  31 c ______________________________________________________________________
  32 c .        .     .        .                                            .
  33 c .  nom   . e/s . taille .           description                      .
  34 c .____________________________________________________________________.
  35 c . numnoe .  s  . mcnvnf . liste des noeuds de calcul de frontiere    .
  36 c . lignoe .  s  . mcnvnf . liste lignes pour ces noeuds               .
  37 c . abscno .  s  . mcnvnf . abscisse curviligne de ces noeuds          .
  38 c . unst2x . e   .   1    . inverse de la taille maximale au carre     .
  39 c . epsid2 . e   .   1    . precision relative pour carre de distance  .
  40 c . coonoe . es  . nbnoto . coordonnees des noeuds                     .
  41 c .        .     . *sdim  .                                            .
  42 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  43 c . hetare . e   . nbarto . historique de l'etat des aretes            .
  44 c . filare . e   . nbarto . premiere fille des aretes                  .
  45 c . np2are . e   . nbarto . noeud milieux des aretes                   .
  46 c . cfaare . e   . nctfar*. codes des familles des aretes              .
  47 c .        .     . nbfare .   1 : famille MED                          .
  48 c .        .     .        .   2 : type de segment                      .
  49 c .        .     .        .   3 : orientation                          .
  50 c .        .     .        .   4 : famille d'orientation inverse        .
  51 c .        .     .        .   5 : numero de ligne de frontiere         .
  52 c .        .     .        .  > 0 si concernee par le suivi de frontiere.
  53 c .        .     .        . <= 0 si non concernee                      .
  54 c .        .     .        .   6 : famille frontiere active/inactive    .
  55 c .        .     .        .   7 : numero de surface de frontiere       .
  56 c .        .     .        . + l : appartenance a l'equivalence l       .
  57 c . famare . es  . nbarto . famille des aretes                         .
  58 c . geocoo . e   .sfnbso**. coordonnees des sommets de la frontiere    .
  59 c . abscur . e   . sfnbse . abscisse curviligne des somm des segments  .
  60 c . somseg . e   . sfnbse . liste des sommets des lignes separees par  .
  61 c                           des 0                                      .
  62 c . seglig . e   .0:sfnbli. pointeur dans le tableau somseg : les      .
  63 c .        .     .        . segments de la ligne i sont aux places de  .
  64 c .        .     .        . seglig(i-1)+1 a seglig(i)-1 inclus         .
  65 c . segnoe . aux . nbnoto . segments lies aux noeuds                   .
  66 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  67 c . langue . e   .    1   . langue des messages                        .
  68 c .        .     .        . 1 : francais, 2 : anglais                  .
  69 c . codret . es  .    1   . code de retour des modules                 .
  70 c .        .     .        . 0 : pas de probleme                        .
  71 c .        .     .        . x : probleme                               .
  72 c ______________________________________________________________________
  73 c
  74 c====
  75 c 0. declarations et dimensionnement
  76 c====
  77 c
  78 c 0.1. ==> generalites
  79 c
  80       implicit none
  81       save
  82 c
  83       character*6 nompro
  84       parameter ( nompro = 'SFLISO' )
  85 c
  86 #include "nblang.h"
  87 #include "cofaar.h"
  88 #include "cofina.h"
  89 c
  90 c 0.2. ==> communs
  91 c
  92 #include "envex1.h"
  93 #include "envca1.h"
  94 #include "front1.h"
  95 #include "front2.h"
  96 #include "dicfen.h"
  97 #include "nbfami.h"
  98 #include "nombno.h"
  99 #include "nombar.h"
 100 #include "impr02.h"
 101 c
 102 c 0.3. ==> arguments
 103 c
 104       double precision unst2x, epsid2
 105       double precision coonoe(nbnoto,sdim), geocoo(sfnbso,*)
 106       double precision abscno(mcnxnf)
 107       double precision abscur(sfnbse)
 108 c
 109       integer numnoe(mcnxnf), lignoe(mcnxnf)
 110       integer seglig(0:sfnbli), somseg(sfnbse)
 111       integer segnoe(nbnoto)
 112       integer somare(2,nbarto), hetare(nbarto), filare(nbarto)
 113       integer np2are(nbarto)
 114       integer famare(nbarto), cfaare(nctfar,nbfare)
 115 c
 116       integer ulsort, langue, codret
 117 c
 118 c 0.4. ==> variables locales
 119 c
 120       integer iaux, jaux
 121       integer lenoeu, larete
 122       integer seg, segm(3)
 123       integer lig, ligv
 124       integer nbsomm
 125       integer nbar00
 126 #ifdef _DEBUG_HOMARD_
 127       integer glop
 128       common / tutu / glop
 129 #endif
 130 c
 131       double precision coop(3), acnoeu
 132 c
 133       integer nbmess
 134       parameter ( nbmess = 20 )
 135       character*80 texte(nblang,nbmess)
 136 c
 137 c 0.5. ==> initialisations
 138 c ______________________________________________________________________
 139 c
 140 c====
 141 c 1. messages
 142 c====
 143 c 1.1. ==> les messages
 144 c
 145 #include "impr01.h"
 146 c
 147 #ifdef _DEBUG_HOMARD_
 148       write (ulsort,texte(langue,1)) 'Entree', nompro
 149       call dmflsh (iaux)
 150 #endif
 151 c
 152       texte(1,4) = '(''. Nombre de '',a,'' du maillage :'',i10)'
 153       texte(1,5) = '(''Boucle sur les aretes'')'
 154       texte(1,6) = '(/,''Arete'',i10,'', sur la ligne'',i10)'
 155       texte(1,7) =
 156      >'(/,'' .. Examen du noeud du cote'',i2,'' :'',i10,'', seg ='',i5)'
 157       texte(1,9) = '(6x,''Une arete est de longueur'')'
 158       texte(1,10) = '(i5,'' aretes sont de longueur'')'
 159       texte(1,11) =
 160      > '(6x,''inferieure a la discretisation de la frontiere'')'
 161       texte(1,12) = '(a,'' Inhibition du sf sur l''''arete'',i10)'
 162       texte(1,20) =
 163      >'(5x,''Examen des noeuds situes sur des extremites de ligne'')'
 164 c
 165       texte(2,4) = '(''. Number of '',a,'' in mesh :'',i10)'
 166       texte(2,5) = '(''Loop over edges'')'
 167       texte(2,6) = '(/,''Edge #'',i10,'', on line'',i10)'
 168       texte(2,7) =
 169      > '(/,'' .. Examination of node #'',i2,'' #'',i10,'', seg ='',i5)'
 170       texte(2,9) = '(6x,''One edge is with length'')'
 171       texte(2,10) = '(i5,'' edges are with length'')'
 172       texte(2,11) =
 173      > '(6x,''lower than the discretization of the boundary'')'
 174       texte(2,12) = '(a,'' Inhibition of bf for the edge #'',i10)'
 175       texte(2,20) = '(5x,''Examination of nodes located on lines'')'
 176 c
 177 #include "impr03.h"
 178 c
 179 c 1.2. ==> a priori, aucun segment n'est attache a un noeud
 180 c
 181       do 12 , lenoeu = 1 , nbnoto
 182         segnoe(lenoeu) = 0
 183    12 continue
 184 c
 185       if ( typsfr.le.2 ) then
 186         nbsomm = 2
 187       else
 188         nbsomm = 3
 189       endif
 190 c
 191       nbar00 = 0
 192 c
 193       mcnvnf = 0
 194 c
 195 #ifdef _DEBUG_HOMARD_
 196       write (ulsort,texte(langue,4)) mess14(langue,3,-1), nbnoto
 197       write (ulsort,texte(langue,4)) mess14(langue,3,1), nbarto
 198 #endif
 199 c
 200 cgn        write(ulsort,90002) 'somseg', somseg
 201 #ifdef _DEBUG_HOMARD_
 202       do 13 , iaux = 1, sfnbli
 203         write(ulsort,90002) 'somseg pour la ligne numero', iaux
 204         jaux = 0
 205         do 131 , seg = seglig(iaux-1)+1, seglig(iaux)-1
 206           jaux = jaux + 1
 207           write(ulsort,90012) '.. sommet numero', jaux, somseg(seg)
 208   131   continue
 209    13 continue
 210 #endif
 211 c
 212 c====
 213 c 2. Boucle sur les aretes qui sont actives et positionnees sur
 214 c    une ligne de frontiere
 215 c    On va situer les sommets sur la ligne
 216 c====
 217 #ifdef _DEBUG_HOMARD_
 218       write (ulsort,*) '2. boucle sur les aretes ; codret = ', codret
 219 #endif
 220 c
 221       if ( codret.eq.0 ) then
 222 c
 223 #ifdef _DEBUG_HOMARD_
 224       write (ulsort,texte(langue,5))
 225 #endif
 226 c
 227       do 20 , larete = 1 , nbarto
 228 c
 229 #ifdef _DEBUG_HOMARD_
 230 c          if ( larete.le.0 .or.
 231 c     >         ( larete.eq.1 .or. larete.eq.8  .or.
 232 c     >           larete.eq.9  ) ) then
 233           if ( larete.le.0 ) then
 234             glop = 1
 235           else
 236             glop = 0
 237           endif
 238 #endif
 239 c
 240         lig = cfaare(cosfli,famare(larete))
 241 #ifdef _DEBUG_HOMARD_
 242           if ( glop.ne.0 ) then
 243       write (ulsort,texte(langue,6)) larete, lig
 244             endif
 245 #endif
 246 c
 247         if ( lig.gt.0 ) then
 248 c
 249         if ( hetare(larete).ne.50 ) then
 250 #ifdef _DEBUG_HOMARD_
 251           if ( glop.ne.0 ) then
 252       iaux = seglig(lig-1) + 1
 253       jaux = seglig(lig)
 254       write (ulsort,90002) 'Sommets extremites de cette ligne',
 255      >somseg(iaux), somseg(jaux-1)
 256             endif
 257 #endif
 258 c
 259 c On parcourt les noeuds de l'arete
 260 c
 261           do 200 , jaux = 1 , nbsomm
 262 c
 263 c 2.1. ==> Le noeud et son segment initial
 264 c
 265             if ( codret.eq.0 ) then
 266 c
 267             if ( jaux.le.2 ) then
 268               lenoeu = somare(jaux,larete)
 269             else
 270               lenoeu = np2are(larete)
 271             endif
 272             seg = segnoe(lenoeu)
 273 #ifdef _DEBUG_HOMARD_
 274           if ( glop.ne.0 ) then
 275             write (ulsort,texte(langue,7)) jaux, lenoeu, seg
 276             if ( seg.lt.0 ) then
 277               write (ulsort,90002)
 278      >        'Le noeud est une extremite de la ligne', lig
 279             elseif ( seg.eq.0 ) then
 280               write (ulsort,*) '... Ce noeud n''est pas encore place.'
 281             else
 282               write (ulsort,90002)
 283      >        'Le noeud a deja ete place sur le segment', seg
 284             endif
 285           endif
 286 #endif
 287 c
 288 c 2.2. ==> Le noeud est une extremite de ligne ou n'a pas ete place
 289 c
 290             if ( seg.le.0 ) then
 291 c
 292               do 221 , iaux = 1 , sdim
 293                 coop(iaux) = coonoe(lenoeu,iaux)
 294   221         continue
 295 c
 296 #ifdef _DEBUG_HOMARD_
 297               if ( glop.ne.0 ) then
 298       write (ulsort,90024) 'apres 221, coop du noeud',
 299      >                     lenoeu, (coop(iaux),iaux=1,sdim)
 300               endif
 301 #endif
 302 c
 303 #ifdef _DEBUG_HOMARD_
 304       write (ulsort,texte(langue,3)) 'SFSENO', nompro
 305 #endif
 306               call sfseno ( coop, lig, unst2x, epsid2,
 307      >                      seglig, somseg, geocoo, abscur,
 308      >                      seg, acnoeu )
 309 c
 310 #ifdef _DEBUG_HOMARD_
 311               if ( glop.ne.0 ) then
 312       write (ulsort,90024) 'apres appel a sfseno, coop du noeud',
 313      >                     lenoeu, (coop(iaux),iaux=1,sdim)
 314       write (ulsort,90004) '==> acnoeu', acnoeu
 315       write (ulsort,90002) 'Ce noeud a ete mis sur le segment', seg
 316               endif
 317 #endif
 318               segm(jaux) = seg
 319 c
 320               if ( seg.ne.0 ) then
 321 c
 322                 do 222 , iaux = 1 , mcnvnf
 323                   if ( numnoe(iaux).eq.lenoeu ) then
 324                     if ( lignoe(iaux).eq.lig ) then
 325 cgn       write (ulsort,*) '     enregistrement deja fait'
 326                      goto 200
 327                     endif
 328                   endif
 329   222           continue
 330 c
 331                 segnoe(lenoeu) = seg
 332 c
 333                 mcnvnf = mcnvnf + 1
 334 cgn      write (ulsort,90002) '   enregistrement a la position', mcnvnf
 335                 numnoe(mcnvnf) = lenoeu
 336                 lignoe(mcnvnf) = lig
 337                 abscno(mcnvnf) = acnoeu
 338 c               les noeuds sont forces sur la frontiere
 339 cgn                acnoeu=0.d0
 340 cgn                do 2222 , iaux = 1 , sdim
 341 cgn                acnoeu = acnoeu+(coonoe(lenoeu,iaux)-coop(iaux))**2
 342 cgn 2222           continue
 343 cgn                write (ulsort,*) 223, lenoeu,acnoeu
 344 #ifdef _DEBUG_HOMARD_
 345           if ( glop.ne.0 .or. lenoeu.eq.-102 ) then
 346       write (ulsort,90024) 'avant 222, coonoe du noeud',
 347      >                     lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim)
 348          endif
 349 #endif
 350                 do 223 , iaux = 1 , sdim
 351 cgn               write (ulsort,*) iaux,coonoe(lenoeu,iaux),coop(iaux)
 352                   coonoe(lenoeu,iaux) = coop(iaux)
 353   223           continue
 354 #ifdef _DEBUG_HOMARD_
 355           if ( glop.ne.0 .or. lenoeu.eq.-102 ) then
 356       write (ulsort,90024) 'apres 223, coonoe du noeud',
 357      >                     lenoeu, (coonoe(lenoeu,iaux),iaux=1,sdim)
 358          endif
 359 #endif
 360 #ifdef _DEBUG_HOMARD_
 361 c
 362               else
 363 c
 364                 codret = codret + 1
 365 #endif
 366 c
 367               endif
 368 c
 369 c 2.3. ==> Le noeud est deja situe sur un segment interieur
 370 c          De quelle ligne ?
 371 c
 372             else
 373 #ifdef _DEBUG_HOMARD_
 374           if ( glop.ne.0 .or. lenoeu.eq.-102 ) then
 375       write (ulsort,90024) ' .... Noeud',
 376      >                     lenoeu,(coonoe(lenoeu,iaux),iaux=1,sdim)
 377       write (ulsort,*) 'deja sur le segment ',seg
 378               endif
 379 #endif
 380 c
 381               call sflise( ligv, seg, seglig,
 382      >                     ulsort, langue, codret)
 383 c
 384               if ( codret.eq.0 ) then
 385 c
 386               if ( ligv.eq.lig ) then
 387 c
 388 c 2.3.1 ==> meme ligne : pas de probleme
 389 c
 390                 segm(jaux) = seg
 391 c
 392               else
 393 c
 394 c 2.3.2 ==> autre ligne : on le retire
 395 c
 396                 segm(jaux) = 0
 397 c
 398               endif
 399 c
 400               endif
 401 c
 402             endif
 403 c
 404             endif
 405 c
 406   200     continue
 407 c
 408 c 2.4. ==> Combien de noeuds de l'arete pointent sur la ligne ?
 409 c
 410           if ( codret.eq.0 ) then
 411 c
 412           if ( segm(1).eq.0 .and. segm(2).eq.0 ) then
 413 c
 414 c 2.4.1. ==> Aucun : impression, et prohibition du sf
 415 c
 416 20100 format(7x,'Arete',i10,' (',2i10,') ->',i4,': ',
 417      > 'un sommet n''est pas situe')
 418              write(ulsort,20100)
 419      >       larete,(somare(iaux,larete),iaux=1,2),lig
 420              iaux = cfaare(cosfin,famare(larete))
 421              famare(larete) = iaux
 422 #ifdef _DEBUG_HOMARD_
 423              if ( glop.ne.0 ) then
 424              write(ulsort,texte(langue,12)) '2.4.1', larete
 425              endif
 426 #endif
 427              if ( mod(hetare(larete),10).eq.2 ) then
 428                do 241 , iaux = 0 , 1
 429                  jaux = cfaare(cosfin,famare(filare(larete)+iaux))
 430                  famare(filare(larete)+iaux) = jaux
 431 #ifdef _DEBUG_HOMARD_
 432              if ( glop.ne.0 ) then
 433              write(ulsort,texte(langue,12)) '2.4.1',filare(larete)+iaux
 434              endif
 435 #endif
 436   241          continue
 437              endif
 438 c
 439           elseif ( abs(segm(1)).eq.abs(segm(2)) ) then
 440 c
 441 c 2.4.2. ==> Les deux ; et ils pointent vers le meme segment
 442 c            Il ne sert plus a rien de suivre la frontiere pour
 443 c            cette arete : on a atteint la discretisation minimale
 444 c
 445 #ifdef _DEBUG_HOMARD_
 446              if ( glop.ne.0 ) then
 447 20200 format(7x,'Arete',i10,' (',2i10,') ->',i4,': ',
 448      > 'meme segment',i10)
 449              write(ulsort,20200)
 450      >       larete,(somare(iaux,larete),iaux=1,2),lig,abs(segm(1))
 451              write(ulsort,texte(langue,12)) '2.4.2', larete
 452              endif
 453 #endif
 454              nbar00 = nbar00 + 1
 455              iaux = cfaare(cosfin,famare(larete))
 456              famare(larete) = iaux
 457              if ( mod(hetare(larete),10).eq.2 ) then
 458                do 242 , iaux = 0 , 1
 459                  jaux = cfaare(cosfin,famare(filare(larete)+iaux))
 460                  famare(filare(larete)+iaux) = jaux
 461 #ifdef _DEBUG_HOMARD_
 462              if ( glop.ne.0 ) then
 463              write(ulsort,texte(langue,12)) '2.4.2',filare(larete)+iaux
 464              endif
 465 #endif
 466   242          continue
 467              endif
 468 c
 469           endif
 470 c
 471           endif
 472 c
 473         endif
 474 c
 475         endif
 476 c
 477    20 continue
 478 c
 479       endif
 480 c
 481 c====
 482 c 3. impressions
 483 c====
 484 #ifdef _DEBUG_HOMARD_
 485       write(ulsort,*) '3. impressions, codret =', codret
 486 #endif
 487 c
 488       if ( nbar00.ne.0 ) then
 489         if ( nbar00.eq.1 ) then
 490           write (ulsort,texte(langue,9))
 491         else
 492           write (ulsort,texte(langue,10)) nbar00
 493         endif
 494         write (ulsort,texte(langue,11))
 495       endif
 496 c
 497 c====
 498 c 4. la fin
 499 c====
 500 c
 501       if ( codret.ne.0 ) then
 502 c
 503 #include "envex2.h"
 504 c
 505       write (ulsort,texte(langue,1)) 'Sortie', nompro
 506       write (ulsort,texte(langue,2)) codret
 507 c
 508       endif
 509 c
 510 #ifdef _DEBUG_HOMARD_
 511       write (ulsort,texte(langue,1)) 'Sortie', nompro
 512       call dmflsh (iaux)
 513 #endif
 514 c
 515       end
 516
 517