src/tool/Suivi_Frontiere/sfctri.F

   1       subroutine sfctri ( somseg, seglig,
   2      >                    tbiaux,
   3      >                    ulsort, langue, codret)
   4 c ______________________________________________________________________
   5 c                             H O M A R D
   6 c
   7 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
   8 c
   9 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  10 c aupres des huissiers de justice Simart et Lavoir a Clamart
  11 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  12 c aupres des huissiers de justice
  13 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  14 c
  15 c    HOMARD est une marque deposee d'Electricite de France
  16 c
  17 c Copyright EDF 1996
  18 c Copyright EDF 1998
  19 c Copyright EDF 2002
  20 c Copyright EDF 2020
  21 c ______________________________________________________________________
  22 c
  23 c   Suivi de Frontiere - ConTRole des Intersections enter les lignes
  24 c   -        -           -  --        -
  25 c ______________________________________________________________________
  26 c .        .     .        .                                            .
  27 c .  nom   . e/s . taille .           description                      .
  28 c .____________________________________________________________________.
  29 c . somseg . e   . sfnbse . liste des sommets des lignes separees par  .
  30 c                           des 0                                      .
  31 c . seglig . e   .0:sfnbli. pointeur dans le tableau somseg : les      .
  32 c .        .     .        . segments de la ligne i sont aux places de  .
  33 c .        .     .        . seglig(i-1)+1 a seglig(i)-1 inclus         .
  34 c . tbiaux . e   . sfnbso . tableau auxiliaire                         .
  35 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  36 c . langue . e   .    1   . langue des messages                        .
  37 c .        .     .        . 1 : francais, 2 : anglais                  .
  38 c . codret . es  .    1   . code de retour des modules                 .
  39 c .        .     .        . 0 : pas de probleme                        .
  40 c .        .     .        . !=0 : nombre d'intersections               .
  41 c ______________________________________________________________________
  42 c
  43 c====
  44 c 0. declarations et dimensionnement
  45 c====
  46 c
  47 c 0.1. ==> generalites
  48 c
  49       implicit none
  50       save
  51 c
  52       character*6 nompro
  53       parameter ( nompro = 'SFCTRI' )
  54 c
  55 #include "nblang.h"
  56 c
  57 c 0.2. ==> communs
  58 c
  59 #include "envex1.h"
  60 c
  61 #include "front1.h"
  62 #include "impr02.h"
  63 c
  64 c 0.3. ==> arguments
  65 c
  66       integer somseg(sfnbse), seglig(0:sfnbli)
  67       integer tbiaux(sfnbso)
  68 c
  69       integer ulsort, langue, codret
  70 c
  71 c 0.4. ==> variables locales
  72 c
  73       integer iaux, jaux, kaux
  74       integer jdeb, jfin
  75       integer extred, extref
  76 c
  77       integer nbmess
  78       parameter ( nbmess = 10 )
  79       character*80 texte(nblang,nbmess)
  80 c
  81 c 0.5. ==> initialisations
  82 c ______________________________________________________________________
  83 c
  84 c====
  85 c 1. initialisations
  86 c====
  87 c
  88 #include "impr01.h"
  89 c
  90 #ifdef _DEBUG_HOMARD_
  91       write (ulsort,texte(langue,1)) 'Entree', nompro
  92       call dmflsh (iaux)
  93 #endif
  94 c
  95       texte(1,4) = '(''. Ligne numero'',i4)'
  96       texte(1,5) =
  97      > '(''.. Le noeud'',i10,'' appartient a'',i3,'' lignes.'')'
  98       texte(1,6) =
  99      > '(''.. Les lignes forment'',i3,'' intersection(s).'')'
 100       texte(1,7) =
 101      > '(''.. Le noeud'',i10,'' est une extremite de la ligne'',i4)'
 102       texte(1,8) = '(''.. Il appartient aussi a la ligne'',i4,/)'
 103 c
 104       texte(2,4) = '(''. Line #"'',i4)'
 105       texte(2,5) =
 106      > '(''.. The vertex #'',i10,'' belongs to'',i3,'' lines.'')'
 107       texte(2,6) =
 108      > '(''.. The lines make'',i3,'' intersection(s).'')'
 109       texte(2,7) =
 110      > '(''.. The vertex #'',i10,'' is end of the line #'',i4)'
 111       texte(2,8) = '(''.. It belongs to the line #'',i4,/)'
 112 c
 113 #include "impr03.h"
 114 c
 115       codret = 0
 116 c
 117 c====
 118 c 2. Recherche des points communs qui ne sont pas des extremites
 119 c====
 120 #ifdef _DEBUG_HOMARD_
 121       write (ulsort,90002) '2. points communs ; codret', codret
 122 #endif
 123 c
 124 c 2.1. ==> Aucun noeud n'appartient a une ligne
 125 c
 126       do 21 , iaux = 1 , sfnbso
 127 c
 128         tbiaux(iaux) = 0
 129 c
 130    21 continue
 131 c
 132 c 2.2. ==> Parcours des lignes
 133 c          Pour chacun de ses noeuds, sauf les extremites, on
 134 c          cumule le nombre de ligne d'appartenance.
 135 c
 136       do 22 , iaux = 1 , sfnbli
 137 c
 138 #ifdef _DEBUG_HOMARD_
 139       write (ulsort,texte(langue,4)) iaux
 140 #endif
 141 c
 142         jdeb = seglig(iaux-1)+2
 143         jfin = seglig(iaux)-2
 144 #ifdef _DEBUG_HOMARD_
 145       write (ulsort,90002) 'extremites', somseg(jdeb-1), somseg(jfin+1)
 146       write (ulsort,90002) 'jdeb, jfin', jdeb, jfin
 147 #endif
 148         do 221 , jaux = jdeb, jfin
 149 c
 150           tbiaux(somseg(jaux)) = tbiaux(somseg(jaux)) + 1
 151 c
 152   221   continue
 153 c
 154    22 continue
 155 c
 156 c 2.3. ==> Aucun noeud ne doit appartenir a plus d'une ligne
 157 c
 158       do 23 , iaux = 1 , sfnbso
 159 c
 160         if ( tbiaux(iaux).gt.1 ) then
 161           write (ulsort,texte(langue,5)) iaux, tbiaux(iaux)
 162           codret = codret + 1
 163         endif
 164 c
 165    23 continue
 166 c
 167 c====
 168 c 3. Recherche des extremites qui sont des points interieurs
 169 c====
 170 #ifdef _DEBUG_HOMARD_
 171       write (ulsort,90002) '3. extremites ; codret', codret
 172 #endif
 173 c
 174 c 3.1. ==> Parcours des lignes
 175 c          On repere les deux extremites et on
 176 c          cherche si elles appartiennent a une autre ligne
 177 c
 178       do 31 , iaux = 1 , sfnbli
 179 c
 180 #ifdef _DEBUG_HOMARD_
 181       write (ulsort,texte(langue,4)) iaux
 182 #endif
 183 c
 184         jdeb = seglig(iaux-1)+1
 185         jfin = seglig(iaux)-1
 186         extred = somseg(jdeb)
 187         extref = somseg(jfin)
 188 #ifdef _DEBUG_HOMARD_
 189       write (ulsort,90002) 'extremites', extred, extref
 190 #endif
 191 c
 192         do 311 , kaux = 1 , sfnbli
 193 c
 194           if ( kaux.ne.iaux ) then
 195 #ifdef _DEBUG_HOMARD_
 196       write (ulsort,texte(langue,4)) kaux
 197 #endif
 198 c
 199             jdeb = seglig(kaux-1)+2
 200             jfin = seglig(kaux)-2
 201 #ifdef _DEBUG_HOMARD_
 202       write (ulsort,90002) 'extremites', somseg(jdeb-1), somseg(jfin+1)
 203       write (ulsort,90002) 'jdeb, jfin', jdeb, jfin
 204 #endif
 205             do 3111 , jaux = jdeb, jfin
 206 c
 207               if ( somseg(jaux).eq.extred .or.
 208      >             somseg(jaux).eq.extref ) then
 209                 codret = codret + 1
 210                 write (ulsort,texte(langue,7)) somseg(jaux), iaux
 211                 write (ulsort,texte(langue,8)) kaux
 212               endif
 213 c
 214  3111       continue
 215 c
 216           endif
 217 c
 218   311   continue
 219 c
 220    31 continue
 221 c
 222 c====
 223 c 4. Bilan
 224 c====
 225 c
 226       if ( codret.ne.0 ) then
 227 c
 228       write (ulsort,texte(langue,6)) codret
 229 c
 230       endif
 231 c
 232 c====
 233 c 5. la fin
 234 c====
 235 c
 236       if ( codret.ne.0 ) then
 237 c
 238 #include "envex2.h"
 239 c
 240       write (ulsort,texte(langue,1)) 'Sortie', nompro
 241       write (ulsort,texte(langue,2)) codret
 242 c
 243       endif
 244 c
 245 #ifdef _DEBUG_HOMARD_
 246       write (ulsort,texte(langue,1)) 'Sortie', nompro
 247       call dmflsh (iaux)
 248 #endif
 249 c
 250       end