src/tool/AV_Conversion/vcequn.F

   1       subroutine vcequn ( laret1, laret2,
   2      >                    noehom, arehom,
   3      >                    somare, povoso, voisom,
   4      >                    ulsort, langue, codret)
   5 c ______________________________________________________________________
   6 c
   7 c                             H O M A R D
   8 c
   9 c Outil de Maillage Adaptatif par Raffinement et Deraffinement d'EDF R&D
  10 c
  11 c Version originale enregistree le 18 juin 1996 sous le numero 96036
  12 c aupres des huissiers de justice Simart et Lavoir a Clamart
  13 c Version 11.2 enregistree le 13 fevrier 2015 sous le numero 2015/014
  14 c aupres des huissiers de justice
  15 c Lavoir, Silinski & Cherqui-Abrahmi a Clamart
  16 c
  17 c    HOMARD est une marque deposee d'Electricite de France
  18 c
  19 c Copyright EDF 1996
  20 c Copyright EDF 1998
  21 c Copyright EDF 2002
  22 c Copyright EDF 2020
  23 c ______________________________________________________________________
  24 c
  25 c    aVant adaptation Conversion - EQUivalence - Noeud
  26 c     -               -            ---           -
  27 c    Cela permet de mettre en association les noeuds lies a une
  28 c    paire d'aretes
  29 c ______________________________________________________________________
  30 c .        .     .        .                                            .
  31 c .  nom   . e/s . taille .           description                      .
  32 c .____________________________________________________________________.
  33 c . laret1 . e   .    1   . numero global de l'arete de depart         .
  34 c . laret2 . e   .    1   . numero global de l'arete d'arrivee         .
  35 c . noehom . es  . nbnoto . liste etendue des homologues par noeuds    .
  36 c . arehom . e   . nbarto . liste etendue des homologues par aretes    .
  37 c . somare . e   .2*nbarto. numeros des extremites d'arete             .
  38 c . povoso . e   .0:nbnoto. pointeur des voisins par sommet            .
  39 c . voisom . e   . nvosom . elements 1d, 2d ou 3d voisins par sommet   .
  40 c . ulsort . e   .   1    . numero d'unite logique de la liste standard.
  41 c . langue . e   .    1   . langue des messages                        .
  42 c .        .     .        . 1 : francais, 2 : anglais                  .
  43 c . codret . es  .    1   . code de retour des modules                 .
  44 c .        .     .        . 0 : pas de probleme                        .
  45 c .        .     .        . 1 : probleme                               .
  46 c ______________________________________________________________________
  47 c
  48 c====
  49 c 0. declarations et dimensionnement
  50 c====
  51 c
  52 c 0.1. ==> generalites
  53 c
  54       implicit none
  55       save
  56 c
  57       character*6 nompro
  58       parameter ( nompro = 'VCEQUN' )
  59 c
  60 #include "nblang.h"
  61 c
  62 c 0.2. ==> communs
  63 c
  64 #include "envex1.h"
  65 c
  66 #include "nombno.h"
  67 #include "nombar.h"
  68 #include "nbutil.h"
  69 #include "impr02.h"
  70 c
  71 c 0.3. ==> arguments
  72 c
  73       integer noehom(nbnoto)
  74       integer laret1, laret2
  75       integer arehom(nbarto)
  76       integer somare(2,nbarto), povoso(0:nbnoto), voisom(nvosom)
  77       integer ulsort, langue, codret
  78 c
  79 c 0.4. ==> variables locales
  80 c
  81       integer larete, noeud, ndaux
  82       integer noeud1, noeud2
  83       integer ideb, ifin
  84       integer iaux, jaux, kaux, laux
  85 c
  86       integer nbmess
  87       parameter ( nbmess = 10 )
  88       character*80 texte(nblang,nbmess)
  89 c
  90 c 0.5. ==> initialisations
  91 c ______________________________________________________________________
  92 c
  93 c====
  94 c 1. initialisations
  95 c====
  96 c
  97 c 1.1. ==> messages
  98 c
  99 #include "impr01.h"
 100 c
 101 #ifdef _DEBUG_HOMARD_
 102       write (ulsort,texte(langue,1)) 'Entree', nompro
 103       call dmflsh (iaux)
 104 #endif
 105 c
 106       texte(1,4) =
 107      >'(''Impossible de trouver l''''homologue du noeud'',i10)'
 108 #ifdef _DEBUG_HOMARD_
 109       texte(1,5) = '(''. Recherche de l''''homologue du noeud'',i10)'
 110       texte(1,6) = '(''Aretes'',i10,'' et'',i10)'
 111       texte(1,7) =
 112      > '(''.. Examen de l''''arete'',i10,'' (homologue'',i10,'')'')'
 113       texte(1,8) = '(''... Noeud'',i10,'' (ndaux)'')'
 114       texte(1,9) = '(''.... Noeud'',i10,'' (somare)'')'
 115 #endif
 116       texte(1,10) = '(a,i10,'' : est homologue de'',i10)'
 117 c
 118       texte(2,4) =
 119      > '(''Homologous for node #'',i10,''cannot be found.'')'
 120 #ifdef _DEBUG_HOMARD_
 121       texte(2,5) = '(''. Search for the homologous for node # '',i10)'
 122       texte(2,6) = '(''Edges'',i10,'' and'',i10)'
 123       texte(2,7) =
 124      > '(''.. Check for edge #'',i10,'' (homologous'',i10,'')'')'
 125       texte(2,8) = '(''... Node'',i10,'' (ndaux)'')'
 126       texte(2,9) = '(''.... Node'',i10,'' (somare)'')'
 127 #endif
 128       texte(2,10) = '(a,i10,'' : is homologous with'',i10)'
 129 c
 130 c====
 131 c 2. explication :
 132 c    en entre, nous avons deux aretes (laret1 et laret2) dont on sait
 133 c    qu'elles sont homologues l'une de l'autre, mais dont aucune des 2
 134 c    paires de noeuds n'a ete declaree homologue. Le but de ce programme
 135 c    est de trouver une de ces deux paires.
 136 c
 137 c                       larete1
 138 c                  O-----------------O
 139 c
 140 c                  O-----------------O
 141 c                       larete2
 142 c
 143 c    On part du premier noeud de l'arete laret1. On passe en revue
 144 c    toutes les aretes dont il est un des sommets.
 145 c    Quand on tombe sur une arete differente de laret1 et qui possede
 146 c    une homologue (aaa sur le croquis ci-dessous), on est bon. On
 147 c    cherche quel est le noeud commun a son homologue (bbb) et laret2.
 148 c    Logiquement, ce noeud commun (noeud2) est l'homologue du noeud de
 149 c    depart (noeud1).
 150 c    Si cela echoue, c'est que le noeud de depart etait l'extremite de
 151 c    la zone en equivalence. On recommence avec l'autre noeud de
 152 c    l'arete laret1.
 153 c    Si cela echoue encore, c'est un probleme. Vraisemblablement parce
 154 c    que l'arete en equivalence est seule dans son coin. On ne peut rien
 155 c    faire ! Il faut que la donnee des noeuds homologues soit presente
 156 c    dans le maillage de depart.
 157 c
 158 c                               O    O    O
 159 c                                \   |   /
 160 c                                 \  |  /
 161 c                                  \ | /
 162 c                       laret1      \|/       aaa
 163 c                  O-----------------O--------------------0
 164 c                                  noeud1
 165 c
 166 c                  O-----------------O--------------------0
 167 c                       laret2     noeud2     bbb
 168 c
 169 c    A la sortie, on aura donc repere une paire de noeuds homologues
 170 c    pour la paire d'aretes desirees. La seconde paire sera reperee
 171 c    dans l'algorithme suivant dans le programme appelant.
 172 c====
 173 c
 174       if ( codret.eq.0 ) then
 175 c
 176 #ifdef _DEBUG_HOMARD_
 177       write (ulsort,texte(langue,6)) laret1, laret2
 178 #endif
 179 c
 180       noeud1 = 0
 181 c
 182       do 21 , iaux = 1 , 2
 183 c
 184         noeud = somare(iaux,laret1)
 185 c
 186 #ifdef _DEBUG_HOMARD_
 187         write (ulsort,texte(langue,5)) noeud
 188 #endif
 189 c
 190         ideb = povoso(noeud-1)+1
 191         ifin = povoso(noeud)
 192 c
 193         do 211 , jaux = ideb , ifin
 194 c
 195           larete = voisom(jaux)
 196 c
 197 #ifdef _DEBUG_HOMARD_
 198           write (ulsort,texte(langue,7)) larete, arehom(larete)
 199 #endif
 200 c
 201           if ( larete.ne.laret1 .and. arehom(larete).ne.0 ) then
 202 c
 203             do 212 , kaux = 1 , 2
 204               ndaux = somare(kaux,abs(arehom(larete)))
 205 #ifdef _DEBUG_HOMARD_
 206               write (ulsort,texte(langue,8)) ndaux
 207 #endif
 208               do 213 , laux = 1 , 2
 209 c
 210 #ifdef _DEBUG_HOMARD_
 211                 write (ulsort,texte(langue,9)) somare(laux,abs(laret2))
 212 #endif
 213                 if ( ndaux.eq.somare(laux,abs(laret2)) ) then
 214                   noeud1 = noeud
 215                   noeud2 = somare(laux,abs(laret2))
 216                   goto 22
 217                 endif
 218 c
 219   213         continue
 220   212       continue
 221 c
 222           endif
 223 c
 224   211   continue
 225 c
 226    21 continue
 227 c
 228       endif
 229 c
 230 c 2.2. ==> enregistrement
 231 c
 232    22 continue
 233 c
 234       if ( noeud1.ne.0 ) then
 235         noehom(noeud1) = - noeud2
 236         noehom(noeud2) = noeud1
 237       else
 238         codret = 5
 239       endif
 240 c
 241 c====
 242 c 3. la fin
 243 c====
 244 c
 245       if ( codret.ne.0 ) then
 246 c
 247 #include "envex2.h"
 248 c
 249 #ifdef _DEBUG_HOMARD_
 250       write (ulsort,texte(langue,1)) 'Sortie', nompro
 251         write (ulsort,texte(langue,2)) codret
 252         write (ulsort,texte(langue,10)) mess14(langue,2,1),
 253      >                                 laret1, laret2
 254         write (ulsort,texte(langue,4)) noeud
 255 #endif
 256 c
 257 #ifdef _DEBUG_HOMARD_
 258       write (ulsort,texte(langue,1)) 'Sortie', nompro
 259       call dmflsh (iaux)
 260 #endif
 261 c
 262       endif
 263 c
 264       end