src/tool/AV_Conversion/vcsfli.F

   1       subroutine vcsfli ( sdimca, nbelem, nbmane, nvosom, nbnoto, nbf,
   2      >                    coonca,
   3      >                    noeele, typele, fameel,
   4      >                    povoso, voisom,
   5      >                    numfam, nomfam, ligfam,
   6      >                    nbli00, nblign, nsomli,
   7      >                    numlig, seglig, somseg,
   8      >                    abscur, tabaux,
   9      >                    ulsort, langue, codret )
  10 c ______________________________________________________________________
  11 c
  12 c                             H O M A R D
  13 c
  14 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  15 c
  16 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  17 c aupres des huissiers de justice Simart et Lavoir a Clamart
  18 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  19 c aupres des huissiers de justice
  20 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  21 c
  22 c    HOMARD est une marque deposee d'Electricite de France
  23 c
  24 c Copyright EDF 1996
  25 c Copyright EDF 1998
  26 c Copyright EDF 2002
  27 c Copyright EDF 2020
  28 c ______________________________________________________________________
  29 c
  30 c    aVant adaptation - Conversion
  31 c     -                 -
  32 c                     - Suivi de Frontiere - creation des LIgnes
  33 c                       -        -                        --
  34 c remarque : vcsfl0 et vcsfli sont des clones
  35 c ______________________________________________________________________
  36 c .        .     .        .                                            .
  37 c .  nom   . e/s . taille .           description                      .
  38 c .____________________________________________________________________.
  39 c . sdimca . e   .    *   . dimension du maillage de calcul            .
  40 c . coonca . e   . nbnoto . coordonnees des noeuds dans le calcul      .
  41 c .        .     . *sdimca.                                            .
  42 c . noeele . e   . nbelem . noeuds des elements                        .
  43 c .        .     .*nbmane .                                            .
  44 c . typele . e   . nbelem . type des elements pour le code de calcul   .
  45 c . fameel . e   . nbelem . famille med des elements                   .
  46 c . povoso . e   .0:nbnoto. pointeur des voisins par sommet            .
  47 c . numfam . e   .   nbf  . donne le vrai numero de famille med        .
  48 c .        .     .        . associee a chaque famille classee selon    .
  49 c .        .     .        . l'ordre d'arrivee                          .
  50 c . nomfam . e   . 10*nbf . nom des familles MED                       .
  51 c . ligfam . e   .  nbf   . numero de la ligne de la famille MED       .
  52 c . nbli00 . e   .   1    . nombre estime de lignes                    .
  53 c . nblign .   s .   1    . nombre reel de lignes                      .
  54 c . nsomli .   s .   1    . nombre de sommets pour decrire les lignes  .
  55 c . seglig .   s .0:nblign. pointeur dans les tableaux somseg et abscur.
  56 c .        .     .        . les segments de la ligne i sont aux places .
  57 c .        .     .        . de seglig(i-1)+1 a seglig(i)-1 inclus      .
  58 c . somseg .   s . nsomli . liste des sommets des lignes separees par  .
  59 c                           des 0                                      .
  60 c . abscur .   s . nsomli . longueur des segments des lignes           .
  61 c . tabaux .  a  . nbarto . tableau auxiliaire                         .
  62 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  63 c . langue . e   .    1   . langue des messages                        .
  64 c .        .     .        . 1 : francais, 2 : anglais                  .
  65 c . codret . es  .    1   . code de retour des modules                 .
  66 c .        .     .        . 0 : pas de probleme                        .
  67 c .        .     .        . 1 : probleme                               .
  68 c ______________________________________________________________________
  69 c
  70 c====
  71 c 0. declarations et dimensionnement
  72 c====
  73 c
  74 c 0.1. ==> generalites
  75 c
  76       implicit none
  77       save
  78 c
  79       character*6 nompro
  80       parameter ( nompro = 'VCSFLI' )
  81 c
  82 #include "nblang.h"
  83 c
  84 c 0.2. ==> communs
  85 c
  86 #include "envex1.h"
  87 #include "refert.h"
  88 #include "rftmed.h"
  89 c
  90 c 0.3. ==> arguments
  91 c
  92       integer sdimca
  93       integer nbelem, nbmane, nvosom, nbnoto, nbf
  94       integer noeele(nbelem,nbmane), typele(nbelem), fameel(nbelem)
  95       integer voisom(nvosom), povoso(0:nbnoto)
  96       integer numfam(nbf), ligfam(nbf)
  97       integer nbli00, nblign, nsomli
  98       integer numlig(nbli00), seglig(0:nbli00), somseg(*)
  99       integer tabaux(nbelem)
 100 c
 101       double precision coonca(nbnoto,sdimca)
 102       double precision abscur(*)
 103 c
 104       character*8 nomfam(10,nbf)
 105 c
 106       integer ulsort, langue, codret
 107 c
 108 c 0.4. ==> variables locales
 109 c
 110       integer iaux
 111       integer el, elx, areext, arete, nrsom, nrsom1, typhom
 112       integer noeext
 113       integer lig, jaux, kaux, compte
 114 c
 115       double precision daux
 116 c
 117 #ifdef _DEBUG_HOMARD_
 118       character*64 saux64
 119 #endif
 120 c
 121       integer nbmess
 122       parameter ( nbmess = 10 )
 123       character*80 texte(nblang,nbmess)
 124 c ______________________________________________________________________
 125 c
 126 c====
 127 c 1. messages
 128 c====
 129 c
 130 #include "impr01.h"
 131 c
 132 #ifdef _DEBUG_HOMARD_
 133       write (ulsort,texte(langue,1)) 'Entree', nompro
 134       call dmflsh (iaux)
 135 #endif
 136 c
 137       texte(1,4) = '(/,''Ligne numero '',i5,/,18(''=''))'
 138       texte(1,5) =
 139      > '(''.'',i5,''-eme famille, de numero MED '',i5,'', de nom '',a)'
 140       texte(1,6) =
 141      > '(''.. Extremite '',i1,'' : noeud '',i10,'', arete '',i10)'
 142       texte(1,7) = '(''.. Nombre d''''aretes :'',i10)'
 143       texte(1,8) = '(''Estimation du nombre total de lignes :'',i10)'
 144       texte(1,9) = '(/,''Nombre total de lignes :'',i10)'
 145       texte(1,10) =
 146      > '(''Nombre de sommets pour decrire les lignes :'',i10)'
 147 c
 148       texte(2,4) = '(/,''Line # '',i5,/,12(''=''))'
 149       texte(2,5) = '(''.'',i5,''-th family, MED # '',i5,'', name '',a)'
 150       texte(2,6) = '(''.. End # '',i1,'' : node '',i10,'', edge '',i10)'
 151       texte(2,7) = '(''.. Number of edges :'',i10)'
 152       texte(2,8) = '(''Estimation of total number of lines :'',i10)'
 153       texte(2,9) = '(/,''Total number of lines :'',i10)'
 154       texte(2,10) = '(''Number of vertices to describe lines :'',i10)'
 155 c
 156 #include "impr03.h"
 157 c
 158       codret = 0
 159 c
 160 #ifdef _DEBUG_HOMARD_
 161       write (ulsort,texte(langue,8)) nbli00
 162 #endif
 163 c
 164 c====
 165 c 2. Conversion
 166 c====
 167 c 2.0. ==> aucune maille ne fait partie d'une ligne
 168 c
 169       do 200 , iaux = 1 , nbelem
 170         tabaux(iaux) = 0
 171   200 continue
 172 c
 173       nblign = 0
 174       seglig(0) = 0
 175       nsomli = 0
 176 c
 177       do 20 , lig = 1 , nbli00
 178 c
 179 c 2.1 ==> recherche d'une extremite de la ligne
 180 c         remarque : il est plus economique de boucler d'abord sur
 181 c                    les familles qui decrivent la ligne courante, puis
 182 c                    sur les noeuds.
 183 c
 184         if ( codret.eq.0 ) then
 185 c
 186 #ifdef _DEBUG_HOMARD_
 187         write (ulsort,texte(langue,4)) lig
 188 #endif
 189 c
 190 c ..... on parcourt les familles MED, pour ne retenir que celles qui
 191 c ..... correspondent a la ligne courante
 192 c
 193         do 21 , kaux = 1 , nbf
 194 c
 195           if ( codret.eq.0 ) then
 196 c
 197           if ( ligfam(kaux).eq.lig ) then
 198 c
 199 #ifdef _DEBUG_HOMARD_
 200             saux64( 1: 8) = nomfam(1,kaux)
 201             saux64( 9:16) = nomfam(2,kaux)
 202             saux64(17:24) = nomfam(3,kaux)
 203             saux64(25:32) = nomfam(4,kaux)
 204             saux64(33:40) = nomfam(5,kaux)
 205             saux64(41:48) = nomfam(6,kaux)
 206             saux64(49:56) = nomfam(7,kaux)
 207             saux64(57:64) = nomfam(8,kaux)
 208             call utlgut ( jaux, saux64, ulsort, langue, codret )
 209             write (ulsort,texte(langue,5))
 210      >                   kaux, numfam(kaux), saux64(1:jaux)
 211 #endif
 212 c
 213 c ......... on parcourt tous les noeuds du maillage
 214 c
 215             do 211 , iaux = 1 , nbnoto
 216 c
 217               if ( codret.eq.0 ) then
 218 c
 219               compte = 0
 220 cgn      if ( lig.ge.0) then
 221 cgn        write(ulsort,90002) 'noeud ',iaux
 222 cgn        write(ulsort,90015) '. pointeur des voisins de',
 223 cgn     >     povoso(iaux-1) + 1, ' a', povoso(iaux)
 224 cgn      endif
 225 c
 226 c ........... on parcourt les aretes voisines du noeud
 227 c ........... on compte combien appartiennent a la famille retenue
 228 c
 229               do 2111, jaux = povoso(iaux-1) + 1, povoso(iaux)
 230 c
 231                 el = voisom(jaux)
 232 cgn      if ( lig.ge.0) then
 233 cgn        write(ulsort,90015) '.. voisin # ',jaux,
 234 cgn     >                ' ; numero et type med',el, medtrf(typele(el))
 235 cgn      endif
 236                 if ( numfam(kaux).eq.fameel(el) ) then
 237 c
 238                   typhom = medtrf(typele(el))
 239                   if ( typhom.eq.tyhse1 .or. typhom.eq.tyhse2 ) then
 240 cgn      if ( lig.ge.0) then
 241 cgn      write(ulsort,90002)'.. La frontiere contient l''arete', el
 242 cgn      endif
 243                     elx = el
 244                     compte = compte + 1
 245                   endif
 246 c
 247                 endif
 248 c
 249  2111         continue
 250 c
 251 c .......... si le noeud n'a qu'une seule arete qui appartient
 252 c .......... a la ligne, c'est une extremite
 253 c
 254               if ( compte.eq.1 ) then
 255                 areext = elx
 256                 noeext = iaux
 257                 goto 2199
 258
 259               endif
 260 c
 261               endif
 262 c
 263   211       continue
 264 c
 265           endif
 266 c
 267           endif
 268 c
 269    21   continue
 270 c
 271  2199  continue
 272 c
 273         endif
 274 c
 275 c 2.2. ==> Liste ordonnee des sommets constituant la ligne
 276 c
 277 #ifdef _DEBUG_HOMARD_
 278         write (ulsort,texte(langue,6)) 1, noeext, areext
 279 #endif
 280 c
 281         if ( codret.eq.0 ) then
 282 c
 283 c 2.2.1. ==> on enregistre le point de depart : la derniere extremite
 284 c            trouvee precedemment
 285 c
 286         nblign = nblign + 1
 287 c
 288         numlig(nblign) = lig
 289 c
 290         nsomli = nsomli + 1
 291         somseg(nsomli) = noeext
 292         abscur(nsomli) = 0.d0
 293 #ifdef _DEBUG_HOMARD_
 294         write(ulsort,90024) 'Debut noeud', noeext, abscur(nsomli)
 295 #endif
 296         nrsom1 = noeext
 297 c
 298         arete = areext
 299         nrsom = noeext
 300         tabaux(arete) = lig
 301 c
 302 c 2.2.2. ==> on va parcourir les aretes de proche en proche
 303 c
 304    22   continue
 305 c
 306 c ..... recherche de l'autre extremite de l'arete courante
 307 #ifdef _DEBUG_HOMARD_
 308         write (ulsort,90012) 'noeuds de l''arete', arete,
 309      >                        noeele(arete,1), noeele(arete,2)
 310 #endif
 311         if ( noeele(arete,1).ne.nrsom ) then
 312           nrsom = noeele(arete,1)
 313         else
 314           nrsom = noeele(arete,2)
 315         endif
 316 c
 317 c ..... incrementation du nombre de sommets
 318 c       . stockage du nouveau sommet
 319 c       . memorisation de la longueur du brin
 320 c
 321         nsomli = nsomli + 1
 322         somseg(nsomli) = nrsom
 323         daux = 0.d0
 324         do 220 , jaux = 1 , sdimca
 325           daux = daux + (coonca(nrsom1,jaux)-coonca(nrsom,jaux))**2
 326   220   continue
 327         abscur(nsomli) = abscur(nsomli-1) + sqrt(daux)
 328 #ifdef _DEBUG_HOMARD_
 329         write(ulsort,90024) 'Suite noeud', nrsom, abscur(nsomli)
 330 #endif
 331         nrsom1 = nrsom
 332 c
 333 c ..... boucle sur les aretes voisines de ce noeud
 334         do 221 , jaux = povoso(nrsom-1) + 1, povoso(nrsom)
 335 c
 336           el = voisom(jaux)
 337           typhom = medtrf(typele(el))
 338 cgn      write (ulsort,90015) 'Maille voisine' , el,' typhom :',typhom
 339 c
 340           if ( typhom.eq.tyhse1 .or. typhom.eq.tyhse2 ) then
 341 c
 342             areext = el
 343 c
 344 c ......... si c'est une nouvelle arete
 345             if ( areext.ne.arete ) then
 346 c
 347 c ........... et si cette arete appartient a la ligne, c'est-a-dire si
 348 c ........... sa famille MED fait partie de la description de la ligne
 349               do 2211 , kaux = 1 , nbf
 350                 if ( numfam(kaux).eq.fameel(areext) ) then
 351                   if ( ligfam(kaux).eq.lig ) then
 352 cgn      write (ulsort,90002) 'on poursuit le trajet avec l''arete', el
 353 c ............... alors on poursuit le trajet
 354                     arete = areext
 355                     tabaux(arete) = lig
 356                     goto 22
 357                   endif
 358                 endif
 359  2211         continue
 360 c
 361             endif
 362 c
 363           endif
 364 c
 365   221   continue
 366 c
 367 c 2.2.3. ==> la ligne est finie
 368 c
 369 #ifdef _DEBUG_HOMARD_
 370         write(ulsort,90024) '  Fin noeud', nrsom, abscur(nsomli)
 371         write (ulsort,texte(langue,6)) 2, nrsom, arete
 372         write (ulsort,texte(langue,7)) nsomli - seglig(nblign-1) - 1
 373 #endif
 374 c
 375         nsomli = nsomli + 1
 376 c
 377         somseg(nsomli) = 0
 378 c
 379         seglig(nblign) = nsomli
 380 c
 381         endif
 382 c
 383    20 continue
 384 cgn      write (ulsort,*) somseg(nsomli-1)
 385 cgn      write (ulsort,*) (seglig(iaux),iaux=0,nblign)
 386 c
 387 #ifdef _DEBUG_HOMARD_
 388       if ( codret.eq.0 ) then
 389       write (ulsort,texte(langue,9)) nblign
 390       write (ulsort,texte(langue,10)) nsomli
 391       endif
 392 #endif
 393 c
 394 c====
 395 c 3. la fin
 396 c====
 397 c
 398       if ( codret.ne.0 ) then
 399 c
 400 #include "envex2.h"
 401 c
 402       write (ulsort,texte(langue,1)) 'Sortie', nompro
 403       write (ulsort,texte(langue,2)) codret
 404 c
 405       endif
 406 c
 407 #ifdef _DEBUG_HOMARD_
 408       write (ulsort,texte(langue,1)) 'Sortie', nompro
 409       call dmflsh (iaux)
 410 #endif
 411 c
 412       end